hi i'm trying to create a list of folders from an excel sheet and in each folder, it should be a txt file named let's say name.txt and in each of these files it should write wats in column b
pic1
I used this code to create the folders but I need help about creating the txt files
Sub MakeFolders()
Dim Rng As Range
Dim maxRows, maxCols, r, c As Integer
Set Rng = Selection
maxRows = Rng.Rows.Count
maxCols = Rng.Columns.Count
For c = 1 To maxCols
r = 1
Do While r <= maxRows
If Len(Dir(ActiveWorkbook.Path & "\" & Rng(r, c), vbDirectory)) = 0 Then
MkDir (ActiveWorkbook.Path & "\" & Rng(r, c))
On Error Resume Next
End If
r = r + 1
Loop
Next c
End Sub
I need help generating the text file in each folder
Create Text Files From Worksheet Data
Sub MakeFolders()
Const fRow As Long = 2
Const SubFolderColumn As String = "A"
Const TextColumn As String = "B"
Const TextFileNameCellAddress As String = "B1"
Dim ws As Worksheet: Set ws = ActiveSheet ' improve!
Dim wbPath As String: wbPath = ws.Parent.Path & "\"
Dim TextFileName As String
TextFileName = CStr(ws.Range(TextFileNameCellAddress).Value)
Dim lRow As Long
lRow = ws.Cells(ws.Rows.Count, SubFolderColumn).End(xlUp).Row
Dim srg As Range: Set srg = ws.Range(ws.Cells(fRow, SubFolderColumn), _
ws.Cells(lRow, SubFolderColumn))
Dim sCell As Range
Dim TextFile As Long
Dim FolderPath As String
Dim SubFolderName As String
Dim FilePath As String
Dim FileText As String
For Each sCell In srg.Cells
SubFolderName = CStr(sCell.Value)
If Len(SubFolderName) > 0 Then
FolderPath = wbPath & SubFolderName & "\"
If Len(Dir(FolderPath, vbDirectory)) = 0 Then
MkDir FolderPath
End If
FilePath = FolderPath & TextFileName
FileText = CStr(sCell.EntireRow.Columns(TextColumn).Value)
' Or (the same):
'FileText = CStr(ws.Cells(sCell.Row, TextColumn).Value)
TextFile = FreeFile
Open FilePath For Output As #TextFile
Print #TextFile, FileText
Close TextFile
End If
Next sCell
MsgBox "Files created.", vbInformation
End Sub
try to use FSO.CreateTextFile:
Sub Macro1()
'
' Macro1 Macro
'
'
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Dim strPath As String
strPath = "d:\name.txt"
Dim oFile As Object
Set oFile = fso.CreateTextFile(strPath)
oFile.WriteLine "test"
oFile.Close
Set fso = Nothing
Set oFile = Nothing
End Sub
Related
I have a code that has been running just fine, however, suddenly I am getting the following error:
I get the error in all the old files as well, even after completely shutting down excel. I also tried adding "AccessibilityCplAdmin 1.0 Type Library", which helped at first but doesn't anymore.
The error is in line "dData(dr, 1) = sheet.Name"
Does anyone know how this could be solved?
Sub ListSheets()
'Call NewFileTabs
Application.ScreenUpdating = False
Const ProcName As String = "ListSheets"
Application.AutomationSecurity = msoAutomationSecurityLow
Dim IsSuccess As Boolean
'On Error GoTo ClearError
'Define locations of where to write
Const dName As String = "Engine"
Const dfcAddress As String = "A1" 'where to write old file tabs
Const dfcAddress_new_file As String = "B1" 'where to write new file tabs
Dim wb_macro As Workbook: Set wb_macro = ThisWorkbook ' workbook containing this code
Dim ws_macro As Worksheet: Set ws_macro = wb_macro.Worksheets(dName)
Dim macro_filename As String: macro_filename = wb_macro.Name
Dim dCell As Range: Set dCell = ws_macro.Range(dfcAddress) 'where to write old tabs
Dim dCell_new As Range: Set dCell_new = ws_macro.Range(dfcAddress_new_file) 'where to write new tabs
Dim sFolderPath As String: sFolderPath = wb_macro.Path & "\"
Application.EnableEvents = False
Dim wb_from As Workbook
Dim new_wb As Workbook
Dim sheet As Object
Dim sht_new As Object
Dim sFilePath As String
Dim sFilePath_newfile As String
Dim dData As Variant
Dim dData_1 As Variant
Dim NewTemplate As Variant
Dim from_nr_sheet As Long
Dim nr_sheet_new_file As Long
Dim dr As Long
Dim dr_new As Long
Dim miss_tab As String
'Get the list of new file tabs (column B)
NewTemplate = Application.GetOpenFilename
If NewTemplate <> False Then
Set new_wb = Workbooks.Open(NewTemplate)
Dim new_wb_name As String: new_wb_name = new_wb.Name
Dim sFolderPath_new As String: sFolderPath_new = new_wb.Path & "\"
Dim sFileName_new As String: sFileName_new = Dir(sFolderPath_new & "*.xlsb*")
sFilePath_newfile = sFolderPath_new & sFileName_new
nr_sheet_new_file = new_wb.Sheets.Count + 1
ReDim dData_1(1 To nr_sheet_new_file, 1 To 1)
dData_1(1, 1) = sFilePath_newfile
dr_new = 1
For Each sht_new In new_wb.Sheets
dr_new = dr_new + 1
dData_1(dr_new, 1) = sht_new.Name
Next sht_new
'new_wb.Close SaveChanges:=False
Range(dCell_new, dCell_new.Offset(UBound(dData_1, 1) - 1)) = dData_1
End If
IsSuccess = True
'Determine all the filepaths in a dedicated loop.
'If this succeeds, the issue is somewhere else
'or the other code is somehow preventing 'Dir' from succeeding
Dim filesOfInterest As Collection
Set filesOfInterest = New Collection
Dim sFileName As String
sFileName = Dir(sFolderPath & "*.xlsb*")
Do While Len(sFileName) > 0
filesOfInterest.Add sFileName
sFileName = Dir
Loop
'Get the list of other tabs (column A)
'Operate on all the filepaths
Dim fileOfInterest As Variant
For Each fileOfInterest In filesOfInterest
If StrComp(fileOfInterest, macro_filename, vbTextCompare) <> 0 Then
sFilePath = sFolderPath & fileOfInterest
Set wb_from = Workbooks.Open(sFilePath)
from_nr_sheet = wb_from.Sheets.Count + 1 ' + 1 for header
ReDim dData(1 To from_nr_sheet, 1 To 1)
dData(1, 1) = sFilePath ' sFileName - write header
dr = 1
For Each sheet In wb_from.Sheets
dr = dr + 1
dData(dr, 1) = sheet.Name
Next sheet
dCell.Resize(from_nr_sheet).Value = dData ' write to destination worksheet
'Copy the tabs over
Workbooks(macro_filename).Sheets("Engine").Activate
Dim rng As Range: Set rng = ActiveSheet.Range("F2:F100")
Dim cel As Range
For Each cel In rng 'look at first 100 different rows
If Not cel.Value = "" Then
miss_tab = cel.Value
wb_from.Sheets(cel.Value).Copy Before:=Workbooks(new_wb_name).Sheets("Core")
End If
Next cel
Call Copy_cells(wb_from, new_wb)
wb_from.Close SaveChanges:=False
new_wb.SaveAs Filename:=sFolderPath_new & fileOfInterest
Set new_wb = Workbooks.Open(sFilePath_newfile)
End If
Workbooks(macro_filename).Sheets("Engine").Activate
Sheets("Engine").Range("A1:A100").ClearContents
Next
Sheets("Engine").Range("A1:B100").ClearContents
new_wb.Close SaveChanges:=False
RefreshLink_folder (sFolderPath_new)
IsSuccess = True
Application.AutomationSecurity = msoAutomationSecurityByUI
Application.ScreenUpdating = True
End Sub
I have a macro that loops through the files in a folder in which the original excel with the macro lies. It then does a bunch of copy paste for each of the files in the folder. The macro works correctly for the first file in the folder, however, it then stops. Does anyone know why this is so (the starts when it says "Get the list of other tabs (column A)")? There are no errors, the macro just stops looping.
Sub ListSheets()
'Call NewFileTabs
Application.ScreenUpdating = False
Const ProcName As String = "ListSheets"
Dim IsSuccess As Boolean
'On Error GoTo ClearError
'Define locations of where to write
Const dName As String = "Engine"
Const dfcAddress As String = "A1" 'where to write old file tabs
Const dfcAddress_new_file As String = "B1" 'where to write new file tabs
Dim wb_macro As Workbook: Set wb_macro = ThisWorkbook ' workbook containing this code
Dim ws_macro As Worksheet: Set ws_macro = wb_macro.Worksheets(dName)
Dim macro_filename As String: macro_filename = wb_macro.Name
Dim dCell As range: Set dCell = ws_macro.range(dfcAddress) 'where to write old tabs
Dim dCell_new As range: Set dCell_new = ws_macro.range(dfcAddress_new_file) 'where to write new tabs
Dim sFolderPath As String: sFolderPath = wb_macro.Path & "\"
Dim sFileName As String: sFileName = Dir(sFolderPath & "*.xls*")
Application.EnableEvents = False
Dim wb_from As Workbook
Dim new_wb As Workbook
Dim sheet As Object
Dim sht_new As Object
Dim sFilePath As String
Dim sFilePath_newfile As String
Dim dData As Variant
Dim dData_1 As Variant
Dim NewTemplate As Variant
Dim from_nr_sheet As Long
Dim nr_sheet_new_file As Long
Dim dr As Long
Dim dr_new As Long
Dim miss_tab As String
'Get the list of new file tabs (column B)
NewTemplate = Application.GetOpenFilename
If NewTemplate <> False Then
Set new_wb = Workbooks.Open(NewTemplate)
Dim new_wb_name As String: new_wb_name = new_wb.Name
Dim sFolderPath_new As String: sFolderPath_new = new_wb.Path & "\"
Dim sFileName_new As String: sFileName_new = Dir(sFolderPath_new & "*.xls*")
sFilePath_newfile = sFolderPath_new & sFileName_new
nr_sheet_new_file = new_wb.Sheets.Count + 1
ReDim dData_1(1 To nr_sheet_new_file, 1 To 1)
dData_1(1, 1) = sFilePath_newfile
dr_new = 1
For Each sht_new In new_wb.Sheets
dr_new = dr_new + 1
dData_1(dr_new, 1) = sht_new.Name
Next sht_new
'new_wb.Close SaveChanges:=False
range(dCell_new, dCell_new.Offset(UBound(dData_1, 1) - 1)) = dData_1
End If
IsSuccess = True
'Get the list of other tabs (column A)
Do While Len(sFileName) > 0
If StrComp(sFileName, macro_filename, vbTextCompare) <> 0 Then
sFilePath = sFolderPath & sFileName
Set wb_from = Workbooks.Open(sFilePath)
from_nr_sheet = wb_from.Sheets.Count + 1 ' + 1 for header
ReDim dData(1 To from_nr_sheet, 1 To 1)
dData(1, 1) = sFilePath ' sFileName - write header
dr = 1
For Each sheet In wb_from.Sheets
dr = dr + 1
dData(dr, 1) = sheet.Name
Next sheet
'wb_from.Close SaveChanges:=False ' it was just read from
dCell.Resize(from_nr_sheet).Value = dData ' write to destination worksheet
'Set dCell = dCell.Offset(, 1) ' next column
'Copy the tabs over
Workbooks(macro_filename).Sheets("Engine").Activate
Dim rng As range: Set rng = ActiveSheet.range("F2:F100")
Dim cel As range
For Each cel In rng 'look at first 100 different tabs
If Not cel.Value = "" Then
miss_tab = cel.Value
wb_from.Sheets(cel.Value).Copy Before:=Workbooks(new_wb_name).Sheets("Core")
End If
Next cel
wb_from.Close SaveChanges:=False
new_wb.SaveAs Filename:=sFolderPath_new & sFileName
End If
sFileName = Dir
Workbooks(macro_filename).Sheets("Engine").Activate
Sheets("Engine").range("A1:B100").ClearContents
Loop
new_wb.Close SaveChanges:=False
IsSuccess = True
Application.ScreenUpdating = True
End Sub
While it may be difficult to determine why it stops looping by observation/review...code can usually be re-organized to help narrow down where/what the problem is.
Given that it currently stops looping after processing the first file, it is clear that Dir is (for whatever reason) returning an empty string after the first file is processed. A first step to debugging the issue would be to isolate the task of getting all the filepaths. Once all the filepaths are determined, Then operate on each file of interest. This step is implemented in the code below.
If loading the filepaths separately fails, then you have a lot less code to debug. If all the filepaths load successfully and the code still fails, then the problem is within the subsequent loop.
As has been commented, it is possible that the code within the Do While loop is somehow preventing Dir from operating properly. If this is the case, then the code below might get the code to work. If the code still fails after collating the filepaths of interest, then start parsing out blocks of functionality within If StrComp(sFileName, macro_filename, vbTextCompare) <> 0 Then. Good luck!
Sub ListSheets()
'Call NewFileTabs
Application.ScreenUpdating = False
Const ProcName As String = "ListSheets"
Dim IsSuccess As Boolean
'On Error GoTo ClearError
'Define locations of where to write
Const dName As String = "Engine"
Const dfcAddress As String = "A1" 'where to write old file tabs
Const dfcAddress_new_file As String = "B1" 'where to write new file tabs
Dim wb_macro As Workbook: Set wb_macro = ThisWorkbook ' workbook containing this code
Dim ws_macro As Worksheet: Set ws_macro = wb_macro.Worksheets(dName)
Dim macro_filename As String: macro_filename = wb_macro.Name
Dim dCell As Range: Set dCell = ws_macro.Range(dfcAddress) 'where to write old tabs
Dim dCell_new As Range: Set dCell_new = ws_macro.Range(dfcAddress_new_file) 'where to write new tabs
Dim sFolderPath As String: sFolderPath = wb_macro.Path & "\"
Application.EnableEvents = False
Dim wb_from As Workbook
Dim new_wb As Workbook
Dim sheet As Object
Dim sht_new As Object
Dim sFilePath As String
Dim sFilePath_newfile As String
Dim dData As Variant
Dim dData_1 As Variant
Dim NewTemplate As Variant
Dim from_nr_sheet As Long
Dim nr_sheet_new_file As Long
Dim dr As Long
Dim dr_new As Long
Dim miss_tab As String
'Get the list of new file tabs (column B)
NewTemplate = Application.GetOpenFilename
If NewTemplate <> False Then
Set new_wb = Workbooks.Open(NewTemplate)
Dim new_wb_name As String: new_wb_name = new_wb.Name
Dim sFolderPath_new As String: sFolderPath_new = new_wb.Path & "\"
Dim sFileName_new As String: sFileName_new = Dir(sFolderPath_new & "*.xls*")
sFilePath_newfile = sFolderPath_new & sFileName_new
nr_sheet_new_file = new_wb.Sheets.Count + 1
ReDim dData_1(1 To nr_sheet_new_file, 1 To 1)
dData_1(1, 1) = sFilePath_newfile
dr_new = 1
For Each sht_new In new_wb.Sheets
dr_new = dr_new + 1
dData_1(dr_new, 1) = sht_new.Name
Next sht_new
'new_wb.Close SaveChanges:=False
Range(dCell_new, dCell_new.Offset(UBound(dData_1, 1) - 1)) = dData_1
End If
IsSuccess = True
'Determine all the filepaths in a dedicated loop.
'If this succeeds, the issue is somewhere else
'or the other code is somehow preventing 'Dir' from succeeding
Dim filesOfInterest As Collection
Set filesOfInterest = New Collection
Dim sFileName As String
sFileName = Dir(sFolderPath & "*.xls*")
Do While Len(sFileName) > 0
filesOfInterest.Add sFileName
sFileName = Dir
Loop
'Get the list of other tabs (column A)
'Operate on all the filepaths
Dim fileOfInterest As Variant
For Each fileOfInterest In filesOfInterest
If StrComp(fileOfInterest, macro_filename, vbTextCompare) <> 0 Then
sFilePath = sFolderPath & fileOfInterest
Set wb_from = Workbooks.Open(sFilePath)
from_nr_sheet = wb_from.Sheets.Count + 1 ' + 1 for header
ReDim dData(1 To from_nr_sheet, 1 To 1)
dData(1, 1) = sFilePath ' sFileName - write header
dr = 1
For Each sheet In wb_from.Sheets
dr = dr + 1
dData(dr, 1) = sheet.Name
Next sheet
'wb_from.Close SaveChanges:=False ' it was just read from
dCell.Resize(from_nr_sheet).Value = dData ' write to destination worksheet
'Set dCell = dCell.Offset(, 1) ' next column
'Copy the tabs over
Workbooks(macro_filename).Sheets("Engine").Activate
Dim rng As Range: Set rng = ActiveSheet.Range("F2:F100")
Dim cel As Range
For Each cel In rng 'look at first 100 different tabs
If Not cel.Value = "" Then
miss_tab = cel.Value
wb_from.Sheets(cel.Value).Copy Before:=Workbooks(new_wb_name).Sheets("Core")
End If
Next cel
wb_from.Close SaveChanges:=False
new_wb.SaveAs Filename:=sFolderPath_new & fileOfInterest
End If
Workbooks(macro_filename).Sheets("Engine").Activate
Sheets("Engine").Range("A1:B100").ClearContents
Next
new_wb.Close SaveChanges:=False
IsSuccess = True
Application.ScreenUpdating = True
End Sub
This worked for me in the end if anyone needs the full code. It takes the answer above, and just adjusts some of the variables:
Sub ListSheets()
'Call NewFileTabs
Application.ScreenUpdating = False
Const ProcName As String = "ListSheets"
Dim IsSuccess As Boolean
'On Error GoTo ClearError
'Define locations of where to write
Const dName As String = "Engine"
Const dfcAddress As String = "A1" 'where to write old file tabs
Const dfcAddress_new_file As String = "B1" 'where to write new file tabs
Dim wb_macro As Workbook: Set wb_macro = ThisWorkbook ' workbook containing this code
Dim ws_macro As Worksheet: Set ws_macro = wb_macro.Worksheets(dName)
Dim macro_filename As String: macro_filename = wb_macro.Name
Dim dCell As range: Set dCell = ws_macro.range(dfcAddress) 'where to write old tabs
Dim dCell_new As range: Set dCell_new = ws_macro.range(dfcAddress_new_file) 'where to write new tabs
Dim sFolderPath As String: sFolderPath = wb_macro.Path & "\"
Application.EnableEvents = False
Dim wb_from As Workbook
Dim new_wb As Workbook
Dim sheet As Object
Dim sht_new As Object
Dim sFilePath As String
Dim sFilePath_newfile As String
Dim dData As Variant
Dim dData_1 As Variant
Dim NewTemplate As Variant
Dim from_nr_sheet As Long
Dim nr_sheet_new_file As Long
Dim dr As Long
Dim dr_new As Long
Dim miss_tab As String
'Get the list of new file tabs (column B)
NewTemplate = Application.GetOpenFilename
If NewTemplate <> False Then
Set new_wb = Workbooks.Open(NewTemplate)
Dim new_wb_name As String: new_wb_name = new_wb.Name
Dim sFolderPath_new As String: sFolderPath_new = new_wb.Path & "\"
Dim sFileName_new As String: sFileName_new = Dir(sFolderPath_new & "*.xls*")
sFilePath_newfile = sFolderPath_new & sFileName_new
nr_sheet_new_file = new_wb.Sheets.Count + 1
ReDim dData_1(1 To nr_sheet_new_file, 1 To 1)
dData_1(1, 1) = sFilePath_newfile
dr_new = 1
For Each sht_new In new_wb.Sheets
dr_new = dr_new + 1
dData_1(dr_new, 1) = sht_new.Name
Next sht_new
'new_wb.Close SaveChanges:=False
range(dCell_new, dCell_new.Offset(UBound(dData_1, 1) - 1)) = dData_1
End If
IsSuccess = True
'Determine all the filepaths in a dedicated loop.
'If this succeeds, the issue is somewhere else
'or the other code is somehow preventing 'Dir' from succeeding
Dim filesOfInterest As Collection
Set filesOfInterest = New Collection
Dim sFileName As String
sFileName = Dir(sFolderPath & "*.xls*")
Do While Len(sFileName) > 0
filesOfInterest.Add sFileName
sFileName = Dir
Loop
'Get the list of other tabs (column A)
'Operate on all the filepaths
Dim fileOfInterest As Variant
For Each fileOfInterest In filesOfInterest
If StrComp(fileOfInterest, macro_filename, vbTextCompare) <> 0 Then
sFilePath = sFolderPath & fileOfInterest
Set wb_from = Workbooks.Open(sFilePath)
from_nr_sheet = wb_from.Sheets.Count + 1 ' + 1 for header
ReDim dData(1 To from_nr_sheet, 1 To 1)
dData(1, 1) = sFilePath ' sFileName - write header
dr = 1
For Each sheet In wb_from.Sheets
dr = dr + 1
dData(dr, 1) = sheet.Name
Next sheet
'wb_from.Close SaveChanges:=False ' it was just read from
dCell.Resize(from_nr_sheet).Value = dData ' write to destination worksheet
'Set dCell = dCell.Offset(, 1) ' next column
'Copy the tabs over
Workbooks(macro_filename).Sheets("Engine").Activate
Dim rng As range: Set rng = ActiveSheet.range("F2:F100")
Dim cel As range
For Each cel In rng 'look at first 100 different rows
If Not cel.Value = "" Then
miss_tab = cel.Value
wb_from.Sheets(cel.Value).Copy Before:=Workbooks(new_wb_name).Sheets("Core")
End If
Next cel
wb_from.Close SaveChanges:=False
new_wb.SaveAs Filename:=sFolderPath_new & fileOfInterest
Set new_wb = Workbooks.Open(sFilePath_newfile)
End If
Workbooks(macro_filename).Sheets("Engine").Activate
Sheets("Engine").range("A1:A100").ClearContents
Next
Sheets("Engine").range("A1:A100").ClearContents
new_wb.Close SaveChanges:=False
IsSuccess = True
Application.ScreenUpdating = True
End Sub
My code below browses through the folder and effectively picks out the required files but the copy paste codes that I have tried did not work for me. Cant use traditional copy paste as column order is not same. Column names are same though.
Sub ImportExcelfiles()
Dim strPath As String
Dim strFile As String
Dim wbSource As Workbook
Dim wsSource As Worksheet
Dim wsTarget As Worksheet
Dim bookName As Worksheet
Dim rowCountSource As Long
Dim colCountSource As Long
Dim rowOutputTarget As Long
Dim colOutputTarget As Long
'Variables for Sheet - Workbook Name
Dim nameCount As Long
Dim fileName As String
Application.DisplayAlerts = False
Application.ScreenUpdating = False
'====================================
'SET THE PATH AND FILE TO THE FOLDER
'====================================
strPath = ThisWorkbook.Worksheets("Control").Range("C4")
fileName = ThisWorkbook.Worksheets("Control").Range("C5")
If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
'set the target worksheet
Set wsTarget = ThisWorkbook.Worksheets("Master Data")
Set bookName = ThisWorkbook.Worksheets("Workbook Name")
'set the initial output row and column count for master data and workbook name
rowOutputTarget = 2
nameCount = 2
'get the first file
strFile = Dir(strPath & "*.xlsx*")
'loop throught the excel files in the folder
Do While strFile <> ""
If InStr(strFile, fileName) > 0 Then
'open the workbook
Set wbSource = Workbooks.Open(strPath & strFile)
Set wsSource = wbSource.Worksheets("Details")
'get the row and column counts
With wsSource
'row count based on column 1 = A
rowCountSource = .Cells(.Rows.Count, 1).End(xlUp).Row
'column count based on row 1
colCountSource = .Cells(1, .Columns.Count).End(xlToLeft).Column
End With
-------------------------------Need help here to copy paste-------------------------------------
'copy and paste from A2
wsSource.Range("A3", "AD" & rowCountSource).Copy
wsTarget.Range("A" & rowOutputTarget).PasteSpecial
Paste:=xlPasteValues
bookName.Range("A" & nameCount).Value = wbSource.Name
nameCount = nameCount + 1
rowOutputTarget = rowOutputTarget + rowCountSource - 2
'close the opened workbook
wbSource.Close SaveChanges:=False
End If
'get the next file
strFile = Dir()
Loop
End Sub
Since the order of the columns is different you have to copy them one at a time.
Sub ImportExcelfiles()
Const ROW_COLNAME = 3
'Variables for Sheet - Workbook Name
Dim wbSource As Workbook
Dim wsTarget As Worksheet, wsName As Worksheet
Dim rowOutputTarget As Long, nameCount As Long
Dim strPath As String, strFile As String, fileName As String
With ThisWorkbook
'set the file and path to folder
strPath = .Sheets("Control").Range("C4")
fileName = .Sheets("Control").Range("C5")
If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
'set the target and name worksheets
Set wsTarget = .Sheets("Master Data")
Set wsName = .Sheets("Workbook Name")
End With
' fill dictionary column name to column number from row 1
Dim dict As Object, k As String, rng As Range
Dim lastcol As Long, lastrow As Long, i As Long, n As Long
Set dict = CreateObject("Scripting.Dictionary")
With wsTarget
lastcol = .Cells(1, .Columns.Count).End(xlToLeft).Column
For i = 1 To lastcol
k = UCase(Trim(.Cells(1, i)))
dict.Add k, i
Next
End With
'set the initial output row and column count for master data and workbook nam
rowOutputTarget = 2
nameCount = 2
'get the first file
strFile = Dir(strPath & "*.xlsx*")
'loop through the excel files in the folder
Dim ar, arH, ky, bHasData
Application.ScreenUpdating = False
Do While strFile <> ""
If InStr(strFile, fileName) > 0 Then
'open the workbook
Set wbSource = Workbooks.Open(strPath & strFile, False, False)
wsName.Range("A" & nameCount).Value = wbSource.Name
nameCount = nameCount + 1
' copy values to arrays
With wbSource.Sheets("Details")
lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
arH = .Range("A1:AD1").Offset(ROW_COLNAME - 1).Value2 ' col names
ar = .Range("A" & ROW_COLNAME & ":AD" & lastrow).Value2
End With
'close the opened workbook
wbSource.Close SaveChanges:=False
' copy each columns
If lastrow > ROW_COLNAME Then
bHasData = False
For n = 1 To UBound(ar, 2)
k = UCase(Trim(arH(1, n)))
' determine target column using dictonary
' as lookup with approx match
i = 0
For Each ky In dict
If InStr(1, k, ky) > 0 Then
i = dict(ky)
Exit For
End If
Next
' valid match
If i > 0 Then
bHasData = True
Set rng = wsTarget.Cells(rowOutputTarget, i).Resize(UBound(ar))
' copy column n of array to column i of target sheet
rng.Value2 = Application.Index(ar, 0, n)
ElseIf Len(k) > 0 Then
Debug.Print "Column '" & k & "' not found " & strFile
End If
Next
If bHasData Then
rowOutputTarget = rowOutputTarget + UBound(ar) + 2
End If
End If
'get the next file
strFile = Dir()
End If
Loop
Application.ScreenUpdating = True
MsgBox nameCount - 2 & " books", vbInformation
End Sub
Import Data From Files in Folder
Option Explicit
Sub ImportExcelfiles()
' Source
Const sName As String = "Details"
Const siFileExtensionPattern As String = ".xlsx" ' maybe ".xls?" ?
Const sfCol As String = "A"
Const slCol As String = "AD"
Const sfRow As Long = 3
' Destination
Const dName As String = "Master Data"
Const dfCellAddress As String = "A2"
' Destination Lookup
Const dlName As String = "Control"
Const dlsFolderPathAddress As String = "C4"
Const dlsFileNamePatternAddress As String = "C5"
' Destination Name
Const dnName As String = "Workbook Name"
Const dnfCellAddress As String = "A2"
Dim dwb As Workbook: Set dwb = ThisWorkbook
' Destination Lookup Worksheet
' (contains the folder path and the partial file name)
Dim dlws As Worksheet: Set dlws = dwb.Worksheets(dlName)
Dim sFolderPath As String: sFolderPath = dlws.Range(dlsFolderPathAddress)
If Right(sFolderPath, 1) <> "\" Then sFolderPath = sFolderPath & "\"
Dim sFileNamePattern As String ' contains i.e. leading and trailing '*'
sFileNamePattern = "*" & dlws.Range(dlsFileNamePatternAddress) & "*"
Dim sFileExtensionPattern As String
sFileExtensionPattern = siFileExtensionPattern
If Left(sFileExtensionPattern, 1) <> "." Then _
sFileExtensionPattern = "." & sFileExtensionPattern
Dim sFileName As String
sFileName = Dir(sFolderPath & sFileNamePattern & sFileExtensionPattern)
If Len(sFileName) = 0 Then
MsgBox "No files found.", vbCritical ' improve!
Exit Sub
End If
' Destination Worksheet (source data will by copied to)
Dim dws As Worksheet: Set dws = dwb.Worksheets(dName)
' Source and Destination Columns Count
Dim cCount As Long
cCount = dws.Columns(slCol).Column - dws.Columns(sfCol).Column + 1
' Destination First Row Range
Dim dfrrg As Range: Set dfrrg = dws.Range(dfCellAddress).Resize(, cCount)
' Destination Name Worksheet (source workbook names will be written to)
Dim dnws As Worksheet: Set dnws = dwb.Worksheets(dnName)
' Destination Name Cell
Dim dnCell As Range: Set dnCell = dnws.Range(dnfCellAddress)
Application.ScreenUpdating = False
' Source
Dim swb As Workbook
Dim sws As Worksheet
Dim srg As Range
Dim slRow As Long
' Destination
Dim drg As Range
' Both
Dim rCount As Long
Do While Len(sFileName) > 0
Set swb = Workbooks.Open(sFolderPath & sFileName)
' Attempt to reference the source worksheet.
On Error Resume Next
Set sws = swb.Worksheets("Details")
On Error GoTo 0
If Not sws Is Nothing Then ' worksheet exists
slRow = sws.Cells(sws.Rows.Count, sfCol).End(xlUp).Row
If slRow >= sfRow Then ' found data in column
rCount = slRow - sfRow + 1
Set srg = sws.Cells(sfRow, sfCol).Resize(rCount, cCount)
Set drg = dfrrg.Resize(rCount)
drg.Value = srg.Value
dnCell.Value = swb.Name
' Reset
Set dfrrg = dfrrg.Offset(rCount)
Set dnCell = dnCell.Offset(1)
'Else ' found no data in column; do nothing
End If
Set sws = Nothing
'Else ' worksheet doesn't exist; do nothing
End If
swb.Close SaveChanges:=False
sFileName = Dir
Loop
Application.ScreenUpdating = True
MsgBox "Data imported.", vbInformation
End Sub
I want to use VBA to create a summary sheet in this workbook (storage workbook) that I am currently working in to go through multiple reports (over 100) and pull certain values.
Each report contains 10+ sheets, but I am only interested in copying cells A4:A5 from the sheets titled Day1, Day2, Day3, etc.
I found success using the code below and creating a module for each Day 1, Day 2, Day 3, etc.
Sub Day1_values()
Dim basebook As Workbook
Dim mybook As Workbook
Dim ws As Worksheet
Dim rnum As Long
Dim FNames As String
Dim MyPath As String
Dim SaveDriveDir As String
Dim Cnum As Integer
Dim cell As Range
Dim foldername As String
Dim getpath As String
Dim myFilePath As String
SaveDriveDir = CurDir
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show = -1 Then
MyPath = .SelectedItems(1)
End If
End With
If MyPath <> "" Then
ChDrive MyPath
ChDir MyPath
FNames = Dir("*.xlsm")
If Len(FNames) = 0 Then
MsgBox "No files in the Directory"
ChDrive SaveDriveDir
ChDir SaveDriveDir
Exit Sub
End If
Application.ScreenUpdating = False
Set basebook = ThisWorkbook
rnum = 2
Do While FNames <> ""
Set mybook = Workbooks.Open(FNames)
' This will add the workbook name in column A
basebook.Worksheets(1).Cells(rnum, "A").Value = mybook.Name
basebook.Worksheets(1).Cells(rnum, "B").Value = mybook.Path
Cnum = 3 'begin pasting the values in column 3
For Each cell In mybook.Worksheets("Day1").Range("A4:A5")
basebook.Worksheets(1).Cells(rnum, Cnum).Value = cell.Value
Cnum = Cnum + 1
Next cell
mybook.Close False
rnum = rnum + 1
FNames = Dir()
Loop
ChDrive SaveDriveDir
ChDir SaveDriveDir
Application.ScreenUpdating = True
End If
End Sub
The problem is that each workbook contains a different number of days. For example report 1 has day1 - day5 and report 2 only has day1 - day2.
The above code doesn't work when I create a module for Day3 because it will see that report 2 does not have a Day3 and the code will break because subscript out of range.
Does anyone have any idea how I can manipulate the code in a way to say that for each workbook, if the sheet name contains Day* to copy cells A4:A5 and paste them in my storage workbook?
There was a similar post here: Loop through worksheets with a specific name and they successfully used this code for their problem:
If ws.Name Like "danger" & "*" Then
ws.Range("A1").Interior.ColorIndex = 37
End If
I just don't know how to add that into my existing code.
Try something like this:
Sub ImportWorksheetData()
Dim basebook As Workbook, mybook As Workbook
Dim ws As Worksheet
Dim MyPath As String
Dim rwResults As Range, nm As String, f
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show = -1 Then
MyPath = .SelectedItems(1)
End If
End With
If Len(MyPath) = 0 Then Exit Sub 'no folder chosen
If Right(MyPath, 1) <> "\" Then MyPath = MyPath & "\" 'ensure trailing \
Set basebook = ThisWorkbook
Set rwResults = basebook.Worksheets(1).Rows(2)
f = Dir(MyPath & "*.xlsm")
Do While Len(f) > 0
Set mybook = Workbooks.Open(MyPath & f)
For Each ws In mybook.Worksheets
'Does the worksheet name match our pattern?
nm = UCase(Replace(ws.Name, " ", "")) 'ignore spaces when checking
If nm Like "DAY#" Or nm Like "DAY##" Then '# = any digit
rwResults.Columns("A").Value = f
rwResults.Columns("B").Value = MyPath
rwResults.Columns("C").Value = ws.Name
rwResults.Columns("D").Value = ws.Range("A4").Value
rwResults.Columns("E").Value = ws.Range("A5").Value
Set rwResults = rwResults.Offset(1, 0) 'move down for next sheet
End If
Next ws
mybook.Close False 'no save
f = Dir()
Loop
End Sub
Collect Data from Workbooks
Option Explicit
Sub CollectData()
Const sPattern As String = "*.xlsm"
Const swsPatternLCase As String = "day*"
Const sAddressesList As String = "A4,A5" ' add more
Const dID As Variant = 1 ' or e.g. "Sheet1" - is safer
Const dFirst As String = "A2" ' Destination First Cell Address
Const dLower As Long = 3 ' first column to write the cell values to
Dim dwb As Workbook: Set dwb = ThisWorkbook
Dim sPath As String
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = dwb.Path & "\"
If .Show = -1 Then
sPath = .SelectedItems(1)
End If
End With
If sPath = "" Then Exit Sub ' dialog canceled
Dim sName As String: sName = Dir(sPath & "\" & sPattern)
If Len(sName) = 0 Then
MsgBox "No files in the Directory"
Exit Sub
End If
Dim sAddresses() As String: sAddresses = Split(sAddressesList, ",")
Dim aUpper As Long: aUpper = UBound(sAddresses)
Dim cCount As Long: cCount = dLower + aUpper
Application.ScreenUpdating = False
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
Dim Dat As Variant: ReDim Dat(1 To cCount)
Dim swb As Workbook
Dim sws As Worksheet
Dim n As Long
Dim a As Long
' Write each worksheet's results to an array ('Dat') and add the array
' to the dictionary ('dict').
Do While sName <> ""
Set swb = Workbooks.Open(sPath & "\" & sName)
Dat(1) = swb.Name
Dat(2) = sPath ' or swb.Path - it's always the same '***
For Each sws In swb.Worksheets
If LCase(sws.Name) Like swsPatternLCase Then
'Dat(2) = sws.Name ' looks more useful '***
For a = 0 To aUpper
Dat(dLower + a) = sws.Range(sAddresses(a)).Value
Next a
n = n + 1
dict.Add n, Dat
End If
Next sws
swb.Close False
sName = Dir()
Loop
Dim rCount As Long: rCount = dict.Count
If rCount > 0 Then
' Write the results from the arrays in the dictionary
' to a 2D one-based array ('dData').
Dim dData As Variant: ReDim dData(1 To rCount, 1 To cCount)
Dim r As Long
Dim c As Long
For Each Dat In dict.Items
r = r + 1
For c = 1 To cCount
dData(r, c) = Dat(c)
Next c
Next Dat
With dwb.Worksheets(dID).Range(dFirst).Resize(, cCount)
' Write the results to the destination range (in one go).
.Resize(rCount).Value = dData
' Clear the contents below the destination range.
.Resize(.Worksheet.Rows.Count - .Row - rCount + 1) _
.Offset(rCount).ClearContents
.EntireColumn.AutoFit
End With
dwb.Save
End If
Application.ScreenUpdating = True
MsgBox "Data collected.", vbInformation, "Collect Data"
End Sub
so my code currently goes through a folder and extracts Ranges of data from every file in the folder into a format set by me, it also extracts the filename.
Now i need to use fso to search for certain string inside the file not the filename, lets say "Smart", and in the file "Smart" appears quite a few times, but i only want to extract it once.
Thank you so much to anyone who is able to provide me the small part of the code or some advices to help me continue on!
Option Explicit
Sub ScanFiles()
Application.ScreenUpdating = False
Dim wks As Worksheet
Set wks = Worksheets.Add
' New worksheet for question 2
Dim wksFSO As Worksheet
' Add headers data
With wks
.Range("A1:E1") = Array("Test", "Temp", "Start", "Type", "FileName", "Test", "EndDate", "Smart", "Er")
End With
' Set your copy ranges
Dim CopyRange(1 To 4) As String
CopyRange(1) = "A18"
CopyRange(2) = "A19"
CopyRange(3) = "A14"
CopyRange(4) = "A19"
' Early Binding - Add "Microsoft Scripting Runtime" Reference
Dim FSO As New Scripting.FileSystemObject
' Set FolderPath
Dim FolderPath As String
FolderPath = "c:\Users\Desktop\Tryout\"
' Set Folder FSO
Dim Folder As Scripting.Folder
Set Folder = FSO.GetFolder(FolderPath)
' Loop thru each file -> Assuming only 6 files
Dim File As Scripting.File
For Each File In Folder.Files
' If loop looking for specific files and copy to new FSOWorksheet
If File.Name Like "ReportFile" Then
wksFSO.Cells(1, 1) = File.Name
End If
Dim wkbData As Workbook
Set wkbData = Workbooks.Open(File.Path)
Dim wksData As Worksheet
ActiveSheet.Name = "Sheet1"
Set wksData = wkbData.Worksheets("Sheet1") ' -> Assume this file has only 1 worksheet
Dim BlankRow As Long
BlankRow = wks.Range("A" & wks.Rows.Count).End(xlUp).Row + 1
Dim i As Long
For i = 1 To 4
wks.Cells(BlankRow, i).Value = wksData.Range(CopyRange(i)).Value
Next i
' Write filename in col E
wks.Cells(BlankRow, 5).Value = File.Name
wkbData.Close False
Next File
Range("A:I").EntireColumn.AutoFit
Application.ScreenUpdating = True
End Sub
This could help you, what it does is it search through the path's folders and each excel file that is inside it for the word that you are going to put in the input box.
Sub SearchFolders()
Dim fso As Object
Dim fld As Object
Dim strSearch As String
Dim strPath As String
Dim strFile As String
Dim wOut As Worksheet
Dim wbk As Workbook
Dim wks As Worksheet
Dim lRow As Long
Dim rFound As Range
Dim strFirstAddress As String
On Error GoTo ErrHandler
Application.ScreenUpdating = False
'Change as desired
strPath = "c:\MyFolder"
'You can enter your smart word here
strSearch = inputbox("Please enter a word to be searched.","Search for a word")
Set wOut = Worksheets.Add
lRow = 1
With wOut
.Cells(lRow, 1) = "Workbook"
.Cells(lRow, 2) = "Worksheet"
.Cells(lRow, 3) = "Cell"
.Cells(lRow, 4) = "Text in Cell"
Set fso = CreateObject("Scripting.FileSystemObject")
Set fld = fso.GetFolder(strPath)
strFile = Dir(strPath & "\*.xls*")
Do While strFile <> ""
Set wbk = Workbooks.Open _
(Filename:=strPath & "\" & strFile, _
UpdateLinks:=0, _
ReadOnly:=True, _
AddToMRU:=False)
For Each wks In wbk.Worksheets
Set rFound = wks.UsedRange.Find(strSearch)
If Not rFound Is Nothing Then
strFirstAddress = rFound.Address
End If
Do
If rFound Is Nothing Then
Exit Do
Else
lRow = lRow + 1
.Cells(lRow, 1) = wbk.Name
.Cells(lRow, 2) = wks.Name
.Cells(lRow, 3) = rFound.Address
.Cells(lRow, 4) = rFound.Value
End If
Set rFound = wks.Cells.FindNext(After:=rFound)
Loop While strFirstAddress <> rFound.Address
Next
wbk.Close (False)
strFile = Dir
Loop
.Columns("A:D").EntireColumn.AutoFit
End With
MsgBox "Done"
ExitHandler:
Set wOut = Nothing
Set wks = Nothing
Set wbk = Nothing
Set fld = Nothing
Set fso = Nothing
Application.ScreenUpdating = True
Exit Sub
ErrHandler:
MsgBox Err.Description, vbExclamation
Resume ExitHandler
End Sub