I have two files with different data in it:
wbTarget file - the one I start macro in
wbSource file - the one I select to find some values in it
Explanation of what I need to achieve:
Take first value in wbTarget file column 2
Find this value in wbSource file L column
If found - take appropriate value from wbSource file A column and put it into wbTarget A column
at the moment I have this code:
Sub knew()
Dim VipFile As String 'the file we choose
Dim wbSource As Workbook 'vip file
Dim wbTarget As Workbook 'this file
Dim Rws As Long, Rng As Range, c As Range
Dim finalrow_A As Integer
Dim finalrow_D As Integer
Dim i As Integer 'counter for values
Application.DisplayAlerts = False 'turn blinking off.
With Application.FileDialog(msoFileDialogFilePicker)
.AllowMultiSelect = False
.Title = "Select the file you saved as xlsx"
.ButtonName = "Select"
.InitialFileName = "C:\"
If .Show = -1 Then 'ok clicked
VipFile = .SelectedItems(1)
Set wbTarget = ActiveWorkbook
Set wbSource = Workbooks.Open(VipFile)
finalrow_A = wbSource.Sheets(1).Cells(Rows.Count, 12).End(xlUp).Row
finalrow_D = wbTarget.ActiveSheet.Cells(Rows.Count, 2).End(xlUp).Row
For i = 1 To finalrow_D
runner = wbTarget.ActiveSheet.Cells(i, 2).Value
If Not Application.IsError(Application.VLookup(runner, wbSource.Sheets(1).Range("A1:M" & finalrow_A), 12, False)) Then
wbTarget.Sheets(1).Range("A" & i) = Application.VLookup(runner, _
wbSource.Sheets(1).Range("A1:M" & finalrow_A), 1, False)
End If
Next i
wbSource.Close
End If
End With
Application.DisplayAlerts = True 'turn blinking back on.
End Sub
I get an error right here:
finalrow_D = wbTarget.ActiveSheet.Cells(Rows.Count, 2).End(xlUp).Row
and some mistakes in vlookup part are possible.
Will appreciate your help!
Thank you very much!
I suspect your error comes from the fact that one workbook is an xlsx format and the other is xls so the number of rows is different. However, your bigger problem is that Vlookup won't work here since the lookup value is to the right of the value you want to return in your data table. You need to use Match instead:
Sub knew()
Dim VipFile As String 'the file we choose
Dim wbSource As Workbook 'vip file
Dim wbTarget As Workbook 'this file
Dim Rws As Long, Rng As Range, c As Range
Dim finalrow_A As Long
Dim finalrow_D As Long
Dim i As Long 'counter for values
Dim vMatch As Variant
Dim runner
Application.DisplayAlerts = False 'turn blinking off.
With Application.FileDialog(msoFileDialogFilePicker)
.AllowMultiSelect = False
.Title = "Select the file you saved as xlsx"
.ButtonName = "Select"
.InitialFileName = "C:\"
If .Show = -1 Then 'ok clicked
VipFile = .SelectedItems(1)
Set wbTarget = ActiveWorkbook
Set wbSource = Workbooks.Open(VipFile)
finalrow_A = wbSource.Sheets(1).Cells(wbSource.Sheets(1).Rows.Count, 12).End(xlUp).Row
finalrow_D = wbTarget.ActiveSheet.Cells(wbTarget.ActiveSheet.Rows.Count, 2).End(xlUp).Row
For i = 1 To finalrow_D
runner = wbTarget.ActiveSheet.Cells(i, 2).Value
vMatch = Application.Match(runner, wbSource.Sheets(1).Range("L1:L" & finalrow_A), 0)
If Not IsError(vMatch) Then
wbTarget.Sheets(1).Range("A" & i).Value = wbSource.Sheets(1).Range("A" & vMatch)
End If
Next i
wbSource.Close
End If
End With
Application.DisplayAlerts = True 'turn blinking back on.
End Sub
Related
I am trying to pull data from a folder containing 300 Workbooks, each named 001, 002 etc.
I am only interested in pulling the data from column G of each file and copying it into a separate folder (each file does not have the same amount if data in row G)
I have been able to copy the data across, but I can't seem to get it to move past column 2 and instead writes over the previous column.
The output needed is:
data from column G workbook"001" pasted into "new sheet" column A
data from column G workbook"002" pasted into "new sheet" column B
and so on
Each file in the folder of 300 only has 1 worksheet each, each labelled: 001,002,...,300
This is the code I already had which results in 2 columns of data where 1 gets replaced by each new sheet instead.
Any help to solve this issue would be greatly appreciated.
Sub Copy()
Dim MyFile As String
Dim Filepath As String
Dim q As Long
Dim ThisCol As Integer
Dim ThisRow As Long
Dim CurS As Worksheet
Dim CurRg As Range
Dim InfCol As Integer
Set CurS = ActiveSheet
ThisRow = ActiveCell.Row
ThisCol = ActiveCell.Column
InfCol = 1
Filepath = "C:..."
MyFile = Dir(Filepath)
Do While Len(MyFile) > 0
If MyFile = "Text to column.xlsm" Then
Exit Sub
End If
Workbooks.Open (Filepath & MyFile)
LastRow = Range("G1").CurrentRegion.Rows.Count
Range("G1", Range("G" & LastRow)).Copy ThisWorkbook.Sheets("Sheet1").Range(CurS.Cells(ThisRow, ThisCol + 1), CurS.Cells(ThisRow, ThisCol + CurS.Cells(ThisRow, InfCol).Value))
ActiveWorkbook.Save
ActiveWorkbook.Close
MyFile = Dir
Loop
End Sub
To properly copy in a new column each time, you need a variable that increments during each loop to offset by one each time. When you use ThisCol + 1 you're always getting the same value because ThisCol is not updated.
Something like this:
Sub Copy()
Dim MyFile As String
Dim Filepath As String
Dim q As Long
Dim ThisCol As Integer
Dim ThisRow As Long
Dim CurS As Worksheet
Dim CurRg As Range
Dim InfCol As Integer
Set CurS = ActiveSheet
ThisRow = ActiveCell.Row
ThisCol = ActiveCell.Column
InfCol = 1
Filepath = ReplacewithyouFilePath
MyFile = Dir(Filepath)
Do While Len(MyFile) > 0
If MyFile = "Text to column.xlsm" Then
Exit Sub
End If
'Let's keep a reference to the workbook
Dim wb As Workbook
Set wb = Workbooks.Open(Filepath & MyFile)
'Let's keep a reference to the first sheet where the data is
Dim ws As Worksheet
Set ws = wb.Sheets(1)
Dim LastRow As Long
LastRow = ws.Range("G1").CurrentRegion.Rows.Count
'We create a variable to increment at each column
Dim Counter As Long
'Let's make the copy operation using the Counter
ws.Range("G1", ws.Range("G" & LastRow)).Copy CurS.Range(CurS.Cells(ThisRow, ThisCol + Counter), CurS.Cells(ThisRow + LastRow - 1, ThisCol + Counter))
'We increment the counter for the next file
Counter = Counter + 1
'We use wb to make sure we are referring to the right workbook
wb.Save
wb.Close
MyFile = Dir
'We free the variables for good measure
Set wb = Nothing
Set ws = Nothing
Loop
End Sub
Import Columns
Sub ImportColumns()
Const FOLDER_PATH As String = "C:\Test"
Const FILE_EXTENSION_PATTERN As String = "*.xls*"
Const SOURCE_WORKSHEET_ID As Variant = 1
Const SOURCE_COLUMN As String = "G"
Const SOURCE_FIRST_ROW As Long = 1
Const DESTINATION_WORKSHEET_NAME As String = "Sheet1"
Const DESTINATION_FIRST_CELL_ADDRESS As String = "A1"
Const DESTINATION_COLUMN_OFFSET As Long = 1
Dim pSep As String: pSep = Application.PathSeparator
Dim FolderPath As String: FolderPath = FOLDER_PATH
If Right(FolderPath, 1) <> pSep Then FolderPath = FolderPath & pSep
Dim DirPattern As String: DirPattern = FolderPath & FILE_EXTENSION_PATTERN
Dim SourceFileName As String: SourceFileName = Dir(DirPattern)
If Len(SourceFileName) = 0 Then
MsgBox "No files found.", vbExclamation
Exit Sub
End If
Dim dwb As Workbook: Set dwb = ThisWorkbook ' workbook containing this code
Dim dws As Worksheet: Set dws = dwb.Worksheets(DESTINATION_WORKSHEET_NAME)
Dim dfCell As Range: Set dfCell = dws.Range(DESTINATION_FIRST_CELL_ADDRESS)
Application.ScreenUpdating = False
Dim swb As Workbook
Dim sws As Worksheet
Dim srg As Range
Dim sfCell As Range
Dim slCell As Range
Do While Len(SourceFileName) > 0
If StrComp(SourceFileName, "Text to column.xlsm", vbTextCompare) _
<> 0 Then ' Why 'Exit Sub'? Is this the destination file?
Set swb = Workbooks.Open(FolderPath & SourceFileName, True, True)
Set sws = swb.Worksheets(SOURCE_WORKSHEET_ID)
Set sfCell = sws.Cells(SOURCE_FIRST_ROW, SOURCE_COLUMN)
Set slCell = sws.Cells(sws.Rows.Count, SOURCE_COLUMN).End(xlUp)
Set srg = sws.Range(sfCell, slCell)
srg.Copy dfCell
' Or, if you only need values without formulas and formats,
' instead, use the more efficient:
'dfCell.Resize(srg.Rows.Count).Value = srg.Value
Set dfCell = dfCell.Offset(, DESTINATION_COLUMN_OFFSET) ' next col.
swb.Close SaveChanges:=False ' we are just reading, no need to save!
'Else ' it's "Text to column.xlsm"; do nothing
End If
SourceFileName = Dir
Loop
Application.ScreenUpdating = True
MsgBox "Columns imported.", vbInformation
End Sub
I am looking for VBA code that would look through several hundred Workbooks and open only ones that have "cash" in the workbook title. It would then pull the second row of the first worksheet down to the last row and append it to a master worksheet.
Although I see the iteration count reaches all one hundred plus workbooks, the code appends only the first few worksheets and stops. Could anyone provide insight as to why that is happening? Thank you in advance!
Sub Pull_Cash_WB_Names()
Dim filename As Variant
Dim a As Integer
a = 1
Dim wbDst As Workbook
Dim wbSrc As Workbook
Dim wsSrc As Worksheet
Dim MyPath As String
Dim strFilename As String
Dim LRow As Long, LCol As Long
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.ScreenUpdating = False
Application.DisplayStatusBar = True
Set wbDst = ThisWorkbook
strFilename = Dir("\\DATA\*Cash*")
Count = 0
Do While strFilename <> ""
Set wbSrc = Workbooks.Open("\\DATA\*Cash*")
Set wsSrc = wbSrc.Worksheets(1)
'copy all cells starting from 2nd row to last column
LRow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
LCol = ActiveSheet.Cells(7, Columns.Count).End(xlToLeft).Column
Cells(2, 1).Resize(LRow - 1, LCol).Select
Selection.Copy
'paste the data into master file
wbDst.Sheets(wbDst.Worksheets.Count).Range("A1").PasteSpecial Paste:=xlPasteValuesAndNumberFormats
'counts the number of iterations
Count = Count + 1
Application.StatusBar = Count
wbSrc.Close False
strFilename = Dir()
Loop
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
See fixes/suggestions below
Sub Pull_Cash_WB_Names()
Const PTH As string = "\\DATA\" 'folder path goes here
Dim wbDst As Workbook
Dim wbSrc As Workbook
Dim strFilename As String
Dim rngCopy AsRange, rngDest as range
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.ScreenUpdating = False
Application.DisplayStatusBar = True
Set wbDst = ThisWorkbook
Set rngDest = wbDst.Sheets(wbDst.Worksheets.Count).Range("A1") 'start pasting here
strFilename = Dir(PTH & "*Daily*Cash*.csv") '#EDIT#
Count = 0
Do While strFilename <> ""
Set wbSrc = Workbooks.Open(PTH & strFilename) 'full path+name
Set rngCopy = wbSrc.Worksheets(1).Range("A1").CurrentRegion 'whole table
Set rngCopy = rngCopy.Offset(1, 0).resize(rngcopy.rows.count-1) 'exclude headers
rngCopy.Copy
'paste the data into master file
rngDest.PasteSpecial Paste:=xlPasteValuesAndNumberFormats
Set rngDest = rngDest.offset(rngCopy.rows.count) 'next paste goes here...
Count = Count + 1
Application.StatusBar = Count
wbSrc.Close False
strFilename = Dir()
Loop
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
My code currently opens a file picker and selects files and a particular column im interested in combining into my master worksheet.
I pick several .csv files and bring in a column of my choosing .
Issue I have are,
1) these files are large, 400kb.
2) I get run time error 1004, copy area and paste area are not the same size and shape. Am I just running out of space on my excel sheet? when i debug i get error on line copyRng.Copy destRng
My end goal is to see and count and see the unique values from Col C(perhaps some other columns) from all my workbooks.
Option Explicit
Dim wsMaster As Workbook, csvFiles As Workbook
Dim Filename As String
Dim File As Integer
Dim r As Long
Public Sub Consolidate()
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
With Application.FileDialog(msoFileDialogOpen)
.AllowMultiSelect = True
.Title = "Select files to process"
.Show
If .SelectedItems.Count = 0 Then Exit Sub
Set wsMaster = ActiveWorkbook
Dim copyRng As Range, destRng As Range
Dim firstRow As Long
For File = 1 To .SelectedItems.Count
Filename = .SelectedItems.Item(File)
If Right(Filename, 4) = ".csv" Then
Set csvFiles = Workbooks.Open(Filename, 0, True)
r = wsMaster.Sheets("Sheet1").Range("C" & Rows.Count).End(xlUp).Row
'' This is the main new part
Set copyRng = csvFiles.Sheets(1).Range("C1:C" & r)
With wsMaster.Sheets("Sheet1")
firstRow = .Cells(.Rows.Count, 2).End(xlUp).Row
Set destRng = .Range("A" & firstRow + 1).Offset(0, 1)
End With
copyRng.Copy destRng
''''''''''
csvFiles.Close SaveChanges:=False 'close without saving
End If
Next File
End With
Set wsMaster = Nothing
Set csvFiles = Nothing
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
Updated code with below recommendation
Option Explicit
Dim wsMaster As Workbook, csvFiles As Workbook
Dim Filename As String
Dim File As Integer
Dim r As Long
Public Sub Consolidate()
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
With Application.FileDialog(msoFileDialogOpen)
.AllowMultiSelect = True
.Title = "Select files to process"
.Show
If .SelectedItems.Count = 0 Then Exit Sub
Set wsMaster = ActiveWorkbook
Dim copyRng As Range, destRng As Range
Dim firstRow As Long
For File = 1 To .SelectedItems.Count
Filename = .SelectedItems.Item(File)
If Right(Filename, 4) = ".csv" Then
Set csvFiles = Workbooks.Open(Filename, 0, True)
r = csvFiles.Sheets(1).Range("C" & Rows.Count).End(xlUp).Row
'' This is the main new part
Set copyRng = csvFiles.Sheets(1).Range("C1:C" & r)
With wsMaster.Sheets("Sheet1")
firstRow = .Cells(.Rows.Count, 2).End(xlUp).Row + 1
Set destRng = .Range("B" & firstRow & "B" & (firstRow + r))
End With
destRng.Value = copyRng.Value
''''''''''
csvFiles.Close SaveChanges:=False 'close without saving
End If
Next File
End With
Set wsMaster = Nothing
Set csvFiles = Nothing
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
Since the number of rows is defined by r you can set the dimensions of the destination range. The change below should fix the copy-paste error and speed up your code by eliminating use of the clipboard (assuming you only want the values to be copied).
If Right(Filename, 4) = ".csv" Then
Set csvFiles = Workbooks.Open(Filename, 0, True)
r = csvFiles.Sheets(1).Range("C" & Rows.Count).End(xlUp).Row
'' This is the main new part
Set copyRng = csvFiles.Sheets(1).Range("C1:C" & r)
With wsMaster.Sheets("Sheet1")
firstRow = .Cells(.Rows.Count, 2).End(xlUp).Row + 1
Set destRng = .Range("B" & firstRow & ":B" & (firstrow + r))
End With
DestRng.value = CopyRng.value
''''''''''
csvFiles.Close SaveChanges:=False 'close without saving
End If
My code runs trough dozens of excel documents, selects range and gives the range to an array. I would like to add up the arrays to get a summarized data then paste the result to an existing worksheet.
The formula should be something like this:
rangeVar = oNewBook.Worksheets(1).Range("A1:D4").Value
sumRange = sumRange + rangeVar
Important! Some cells in the range is empty (I don't know is this matters). Also I would like to add up the values separately like sumRange(1,1)+rangeVar(1,1) ; sumRange(2,2)+rangeVar(2,2) , etc... How to do this?
You can check the code here:
Sub LoopAllExcelFilesInFolder()
Dim OutputWs As Worksheet
Dim oNewBook As Workbook
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim FldrPicker As FileDialog
Dim Lastrow As Long
Dim i As Integer, j As Integer
Dim summaryVar() As Variant
Dim rangeVar() As Variant
'Optimize Macro Speed
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
'Retrieve Target Folder Path From User
Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)
With FldrPicker
.Title = "Select A Target Folder"
.AllowMultiSelect = False
If .Show <> -1 Then GoTo NextCode
myPath = .SelectedItems(1) & "\"
End With
'In Case of Cancel
NextCode:
myPath = myPath
If myPath = "" Then GoTo ResetSettings
'Target File Extension
myExtension = "*.xlsx"
'Target Path with Ending Extention
myFile = Dir(myPath & myExtension)
'set output worksheet
Set OutputWs = ThisWorkbook.Worksheets("Teszt")
'Loop through each Excel file in folder
Do While myFile <> ""
Set oNewBook = Workbooks.Open(myPath & myFile)
rangeVar = oNewBook.Worksheets(1).Range("A1:D4").Value
oNewBook.Close
'Copy selected items
With OutputWs
Lastrow = .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0).Row
OutputWs.Range("A" & Lastrow & ":" & "D" & Lastrow) = Application.WorksheetFunction.Sum(rangeVar) 'summaryVar
Paste:=xlPasteAll, operation:=xlPasteSpecialOperationAdd, skipBlanks:=False
Application.CutCopyMode = False
End With
'Get next file name
myFile = Dir
Loop
'Message Box when tasks are completed
MsgBox "Task Complete!"
ResetSettings:
'Reset Macro Optimization Settings
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
S. Meaden answers this question wonderfully in How to add arrays?. Instead of trying to add the two arrays together, he makes use of Excel's pasteSpecial Addvalues function to add the original range's values to another range. Based on his code, something like the below should work.
Set tempWS = Sheets.Add
Do While myFile <> ""
Set oNewBook = Workbooks.Open(myPath & myFile)
oNewBook.Worksheets(1).Range("A1:D4").Copy
tempWS.Range("A1:D4").PasteSpecial Paste:=xlPasteAll, operation:=xlPasteSpecialOperationAdd
oNewBook.Close
Standard Excel Worksheet Functions will work on 1 and 2 dimensional arras.
Sub Test()
Dim array2(25, 25) As Double
Dim i As Integer, j As Integer
For i = 0 To UBound(array2, 1)
For j = 0 To UBound(array2, 1)
array2(i, j) = Int((Rnd * 100) + 1)
Next
Next
MsgBox WorksheetFunction.Sum(array2)
End Sub
I am trying to use a file picker, which I have and then get the columns of every file and every sheet within that file into a new sheet. So A1 would have file name,B1 sheet name, C1 and down would have column headers (which are A1:?? in all the files Im picking).
Also some files are large so would having automatic calculation to automatic be helpful?
Also note that I have extra variables in the beggining but not necessarily used.
Here is the code, its a mess:
Sub ColumnHeaders()
'includes filling down
'Skips unreadable files
Dim wb As Workbook, fileNames As Object, errCheck As Boolean
Dim ws As Worksheet, wks As Worksheet, wksSummary As Worksheet
Dim y As Range, intRow As Long, i As Integer
Dim r As Range, lr As Long, myrg As Range, z As Range
Dim boolWritten As Boolean, lngNextRow As Long
Dim intColNode As Integer, intColScenario As Integer
Dim intColNext As Integer, lngStartRow As Long
Dim lngLastNode As Long, lngLastScen As Long
'Skipped worksheet for file names
Dim wksSkipped As Worksheet
Set wksSkipped = ThisWorkbook.Worksheets("Skipped")
' Turn off screen updating and automatic calculation
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
' Create a new worksheet, if required
On Error Resume Next
Set wksSummary = ActiveWorkbook.Worksheets("Headers")
On Error GoTo 0
If wksSummary Is Nothing Then
Set wksSummary = ActiveWorkbook.Worksheets.Add(After:=ActiveWorkbook.Worksheets(ActiveWorkbook.Worksheets.Count))
wksSummary.Name = "headers"
End If
' Set the initial output range, and assign column headers
With wksSummary
Set y = .Cells(.Rows.Count, 3).End(xlUp).Offset(1, 0)
Set r = y.Offset(0, 1)
Set z = y.Offset(0, -2)
lngStartRow = y.Row
.Range("A1:C1").Value = Array("File Name", "Sheet Name", "headers")
End With
'get user input for files to search
Set fileNames = CreateObject("Scripting.Dictionary")
errCheck = UserInput.FileDialogDictionary(fileNames)
If errCheck Then
Exit Sub
End If
'''
For Each Key In fileNames 'loop through the dictionary
On Error Resume Next
Set wb = Workbooks.Open(fileNames(Key))
If Err.Number <> 0 Then
Set wb = Nothing ' or set a boolean error flag
End If
On Error GoTo 0 ' or your custom error handler
If wb Is Nothing Then
wksSkipped.Cells(wksSkipped.Cells(wksSkipped.Rows.Count, "A").End(xlUp).Row + 1, 1) = fileNames(Key)
Else
Debug.Print "Successfully loaded " & fileNames(Key)
wb.Application.Visible = False 'make it not visible
' more working with wb
Code should go in here
wb.Close savechanges:=False 'close the workbook do not save
Set wb = Nothing 'release the object
End If
Next 'End of the fileNames loop
Set fileNames = Nothing
' Autofit column widths of the report
wksSummary.Range("A1:C1").EntireColumn.AutoFit
' Reset system settings
With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
.Visible = True
End With
End Sub
I have the picker(a separate function) , I a skipped worksheet incase the file is corrupt, but I obviously am missing the part where to get the headers and sheet names.
Can anyone help?
UPDATE WITH MATTHEW'S CODE~~~~~~~~~~~~~~~~~~~~
Sub ColumnHeaders()
'includes filling down
'Skips unreadable files
Dim wb As Workbook, fileNames As Object, errCheck As Boolean
Dim ws As Worksheet, wks As Worksheet, wksSummary As Worksheet
Dim y As range, intRow As Long, i As Integer
Dim r As range, lr As Long, myrg As range, z As range
Dim boolWritten As Boolean, lngNextRow As Long
Dim intColNode As Integer, intColScenario As Integer
Dim intColNext As Integer, lngStartRow As Long
Dim lngLastNode As Long, lngLastScen As Long
'need addition
Dim wsReport As Excel.Worksheet
Set wsReport = ActiveWorkbook.Sheets("Sheet1") 'Whatever sheet you want to write to
'Skipped worksheet for file names
Dim wksSkipped As Worksheet
Set wksSkipped = ThisWorkbook.Worksheets("Skipped")
' Turn off screen updating and automatic calculation
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
' Create a new worksheet, if required
On Error Resume Next
Set wksSummary = ActiveWorkbook.Worksheets("Headers")
On Error GoTo 0
If wksSummary Is Nothing Then
Set wksSummary = ActiveWorkbook.Worksheets.Add(After:=ActiveWorkbook.Worksheets(ActiveWorkbook.Worksheets.Count))
wksSummary.Name = "headers"
End If
' Set the initial output range, and assign column headers
With wksSummary
Set y = .Cells(.Rows.Count, 3).End(xlUp).Offset(1, 0)
Set r = y.Offset(0, 1)
Set z = y.Offset(0, -2)
lngStartRow = y.Row
.range("A1:C1").Value = Array("File Name", "Sheet Name", "headers")
End With
'get user input for files to search
Set fileNames = CreateObject("Scripting.Dictionary")
errCheck = UserInput.FileDialogDictionary(fileNames)
If errCheck Then
Exit Sub
End If
'''
For Each Key In fileNames 'loop through the dictionary
On Error Resume Next
Set wb = Workbooks.Open(fileNames(Key))
If Err.Number <> 0 Then
Set wb = Nothing ' or set a boolean error flag
End If
On Error GoTo 0 ' or your custom error handler
If wb Is Nothing Then
wksSkipped.Cells(wksSkipped.Cells(wksSkipped.Rows.Count, "A").End(xlUp).Row + 1, 1) = fileNames(Key)
Else
Debug.Print "Successfully loaded " & fileNames(Key)
wb.Application.Visible = False 'make it not visible
' more working with wb
'New addition
Dim iIndex As Integer
Dim lCol As Long
Dim lRow As Long
lRow = 1
'Loop through the worksheets in the current workbook.
For iIndex = 1 To wb.Worksheets.Count
'Set the current worksheet
Set ws = Application.Worksheets(iIndex)
'List out the workbook and worksheet names
wsReport.range("A" & lRow).Value = wb.Name
wsReport.range("B" & lRow).Value = ws.Name
'Start a counter of the columns that we are writing to
lOutputCol = 3
'Loop through the columns.
For lCol = 1 To ws.UsedRange.Columns.Count
'Write the header
wsReport.range(Col_Letter(lOutputCol) & lRow).Value = ws.range(Col_Letter(lCol) & "1").Value
'Increment our column counters.
lOutputCol = lOutputCol + 1
lCol = lCol + 1
Next lCol
'Increment the row we are writing to
lRow = lRow + 1
Next iIndex
wb.Close savechanges:=False 'close the workbook do not save
Set wb = Nothing 'release the object
End If
Next 'End of the fileNames loop
Set fileNames = Nothing
' Autofit column widths of the report
wksSummary.range("A1:C1").EntireColumn.AutoFit
' Reset system settings
With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
.Visible = True
End With
End Sub
TWO FUNCTIONS:
Function Col_Letter(lngCol As Long) As String
Dim vArr
vArr = Split(Cells(1, lngCol).Address(True, False), "$")
Col_Letter = vArr(0)
End Function
and
Function FileDialogDictionary(ByRef file As Object) As Boolean ' returns true if the user cancels
'Declare a variable as a FileDialog object.
Dim fd As FileDialog
Dim item As Variant
Dim i As Long
'Create a FileDialog object as a File Picker dialog box.
file.RemoveAll 'clear the dictionary
Set fd = Application.FileDialog(msoFileDialogFilePicker)
'Declare a variable to contain the path
'of each selected item. Even though the path is a String,
'the variable must be a Variant because For Each...Next
'routines only work with Variants and Objects.
'Use a With...End With block to reference the FileDialog object.
With fd
'Use the Show method to display the File Picker dialog box and return the user's action.
'The user pressed the action button.
.Title = "Select Excel Workbooks" 'Change this to suit your purpose
.AllowMultiSelect = True
.Filters.Clear
.Filters.Add "Microsoft Excel files", "*.xlsx,*.xls"
If .Show = -1 Then
'Step through each string in the FileDialogSelectedItems collection.
For Each item In .SelectedItems 'loop through all selected and add to dictionary
i = i + 1
file.Add i, item
Next item
FileDialogDictionary = False
'The user pressed Cancel.
Else
FileDialogDictionary = True
Set fd = Nothing
Exit Function
End If
End With
Set fd = Nothing 'Set the object variable to Nothing.
End Function
When you open a workbook it becomes active so you'll need to create an object that will be the sheet that you are writing to. Somewhere at the top.
Dim wsReport As Excel.Worksheet
Set wsReport = ActiveWorkbook.Sheets("Sheet1") 'Whatever sheet you want to write to
Code to write out the data. Insert where you put "Code should go in here"
Dim iIndex As Integer
Dim lCol As Long
Dim lRow As Long
Dim lOutputCol As Long
lRow = 1
'Loop through the worksheets in the current workbook.
For iIndex = 1 To wb.Worksheets.count
'Set the current worksheet
Set ws = Application.Worksheets(iIndex)
'List out the workbook and worksheet names
wsReport.Range("A" & lRow).Value = wb.name
wsReport.Range("B" & lRow).Value = ws.name
'Start a counter of the columns that we are writing to
lOutputCol = 3
'Loop through the columns.
For lCol = 1 To ws.UsedRange.Columns.count
'Write the header
wsReport.Range(Col_Letter(lOutputCol) & lRow).Value = ws.Range(Col_Letter(lCol) & "1").Value
'Increment our column counters.
lOutputCol = lOutputCol + 1
Next lCol
'Increment the row we are writing to
lRow = lRow + 1
Next iIndex
And you'll need to add this function
Function Col_Letter(lngCol As Long) As String
Dim vArr
vArr = Split(Cells(1, lngCol).Address(True, False), "$")
Col_Letter = vArr(0)
End Function