#1
|
|||
|
|||
Macro to loop in subfolders, change links, export xml data
Hello,
Here i come again with another interesting challenge: to export data from a big number of subfolders , ALMOST each subfolder containing two source excel workbooks, filled with data, and export that data, for every client, in an xml file, for use in another PDF forms. Manually, i change the links in this collector to the next client, and after that, save and export data to xml. The only problem is there are hundreds of subfolders (clients) So i began working on this macro, but cannot find yet a way to make the macro search for new link path for the 2 excel files connections in next subfolder . Can you point me to the best way to do this? Thanks in advance, Catalin B. Sub Macrocomandă2() ' I need for this workbook, which is linked to 2 other workbooks, and has atached an xsd schema, to loop through subfolders, changing links, saving and ' exporting data to xml file, in order to import this data to PDF forms ChDir "E:\Sesiunea 4 - 141-iunie 2011\Acatincai Luminita" ' This, and all other target subfolders is a subfolder of "E:\Sesiunea 4 - 141-iunie 2011\" ' In almost every subfolder, there are 2 workbooks, one with text "plan afaceri" in the file name, ' the other with text "date personale" in the file name ActiveWorkbook.ChangeLink Name:= _ "E:\Sesiunea 4 - 141-iunie 2011\Acatincai Luminita\141-plan afaceri Acatincăi.xls" _ , NewName:= _ "E:\Sesiunea 4 - 141-iunie 2011\Acatincai Luminita\141-plan afaceri Acatincăi.xls" _ , Type:=xlExcelLinks ' this the old path for the first linked workbook, with text "plan afaceri" in the filename ' I need to set the old link name to the existing link path, ' and the new path name to the excel files in the next subfolder, which contains in the ' file name the text "plan afaceri" for a set of links, ' and "date personale" for the second linked workbook ' If in the next subfolder in range one of the excel files containing in the filename ' "plan afaceri" or "date personale" is missing, the macro should change the links to files in the next subfolder ' this the old path for the second linked workbook, with text "date personale" in the filename ActiveWorkbook.ChangeLink Name:= _ "E:\Sesiunea 4 - 141-iunie 2011\Acatincai Luminita\Date personale, chestionar, acte necesare 141- Acatincai Luminita.xls" _ , NewName:= _ "E:\Sesiunea 4 - 141-iunie 2011\Acatincai Luminita\Date personale, chestionar, acte necesare 141- Acatincai Luminita.xls" _ , Type:=xlExcelLinks 'After changing the links for "plan afaceri" and "date personale", all i need 'is to execute the folowing commands after every change of links Application.DisplayAlerts = False ActiveWorkbook.Save Application.DisplayAlerts = True ActiveWorkbook.XmlMaps("pdf_121_Asociere").Export URL:= _ "C:\Users\Catalin\Desktop\Cereri finantare\ " & Sheets("Foaie1").Range("b3").Value & "" _ , Overwrite:=True ' Obviously, in B3 there is the client name with &".xml" attached End Sub |
#2
|
|||
|
|||
Well, i ended with this codes :
Option Explicit '32-bit API declarations Declare Function SHGetPathFromIDList Lib "shell32.dll" _ Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long Declare Function SHBrowseForFolder Lib "shell32.dll" _ Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long Public Type BROWSEINFO hOwner As Long pidlRoot As Long pszDisplayName As String lpszTitle As String ulFlags As Long lpfn As Long lParam As Long iImage As Long End Type Sub GetAllFiles() Dim Msg As String Dim Directory As String Msg = "Select the folder for the recursive directory listing." Directory = GetDirectory(Msg) If Directory = "" Then Exit Sub If Right(Directory, 1) <> "\" Then Directory = Directory & "\" Cells.ClearContents Call RecursiveDir(Directory) End Sub Public Sub RecursiveDir(ByVal CurrDir As String) Dim Dirs() As String Dim NumDirs As Long Dim FileName As String Dim PathAndName As String Dim i As Long ' Make sure path ends in backslash If Right(CurrDir, 1) <> "\" Then CurrDir = CurrDir & "\" ' Put column headings on active sheet Cells(1, 1) = "Path" Cells(1, 2) = "Filename" Cells(1, 3) = "Size" Cells(1, 4) = "Date/Time" Range("A1:D1").Font.Bold = True ' Get files FileName = Dir(CurrDir & "*.*", vbDirectory) Do While Len(FileName) <> 0 If Left(FileName, 1) <> "." Then 'Current dir PathAndName = CurrDir & FileName If (GetAttr(PathAndName) And vbDirectory) = vbDirectory Then 'store found directories ReDim Preserve Dirs(0 To NumDirs) As String Dirs(NumDirs) = PathAndName NumDirs = NumDirs + 1 Else 'Write the path and file to the sheet Cells(WorksheetFunction.CountA(Range("A:A")) + 1, 1) = CurrDir Cells(WorksheetFunction.CountA(Range("B:B")) + 1, 2) = FileName Cells(WorksheetFunction.CountA(Range("C:C")) + 1, 3) = FileLen(PathAndName) Cells(WorksheetFunction.CountA(Range("D:D")) + 1, 4) = FileDateTime(PathAndName) End If End If FileName = Dir() Loop ' Process the found directories, recursively For i = 0 To NumDirs - 1 RecursiveDir Dirs(i) Next i End Sub Function GetDirectory(Optional Msg) As String Dim bInfo As BROWSEINFO Dim path As String Dim r As Long, x As Long, pos As Integer ' Root folder = Desktop bInfo.pidlRoot = 0& ' Title in the dialog If IsMissing(Msg) Then bInfo.lpszTitle = "Select a folder." Else bInfo.lpszTitle = Msg End If ' Type of directory to return bInfo.ulFlags = &H1 ' Display the dialog x = SHBrowseForFolder(bInfo) ' Parse the result path = Space$(512) r = SHGetPathFromIDList(ByVal x, ByVal path) If r Then pos = InStr(path, Chr$(0)) GetDirectory = Left(path, pos - 1) Else GetDirectory = "" End If End Function Function GetFormulaI(Cell As Range) As String 'Application.Volatile = True If VarType(Cell) = 8 And Not Cell.HasFormula Then GetFormulaI = "'" & Cell.Formula Else GetFormulaI = Cell.Formula End If If Cell.HasArray Then _ GetFormulaI = "{" & Cell.Formula & "}" End Function And this: Sub Macro2() Dim i As Integer For i = 2 To 275 Step 2 ActiveWorkbook.ChangeLink Name:= _ Sheets("Foaie1").Cells(2, 9).Value _ , NewName:= _ Sheets("Foaie2").Cells(i + 2, 3).Value _ , Type:=xlExcelLinks ActiveWorkbook.ChangeLink Name:= _ Sheets("Foaie1").Cells(3, 9).Value _ , NewName:= _ Sheets("Foaie2").Cells(i + 3, 3).Value _ , Type:=xlExcelLinks Application.DisplayAlerts = False ActiveWorkbook.Save Application.DisplayAlerts = True ActiveWorkbook.XmlMaps("pdf_121_Asociere").Export URL:= _ "C:\Users\Catalin\Desktop\Cereri finantare\ " & Sheets("Foaie1").Range("b3").Value & "" _ , Overwrite:=True Next i End Sub The problem is that the workbook with the path in red is password protected, and prompts for password at every change of links... Unfortunately, i couldn't find a way to paste the password in the prompt for password for changing links.. There is no need to open the workbook, the paste password works only for workbook open, update links. Is there a way to capture the prompt for password window and to insert password? |
#3
|
|||
|
|||
Quote:
|
|
Similar Threads | ||||
Thread | Thread Starter | Forum | Replies | Last Post |
Made a mistake with a macro change | lance_kidd | Word | 0 | 02-09-2011 06:36 PM |
Accessing Outlook Contacts in Subfolders | jill5545 | Outlook | 1 | 11-17-2010 04:01 PM |
Create a Custome Form and export data to Access | ashleybyrdnc | Office | 0 | 03-05-2010 09:41 AM |
Macro to export document sections to individual txt files? | MJMR999 | Excel Programming | 0 | 02-18-2010 12:49 PM |
Subfolders in Inbox and Sent Items | stevie | Outlook | 0 | 09-08-2009 02:02 AM |