VBA - Copy specific cell from all files within a folder and pasting each file copied column as a separate column in a master table
I have alot of files with a single sheet (sometimes the sheets are named different but they contain similar data arrangement). I need to copy a specific column from every workbook in folder and each of these copied columns need to be tabulated into a master table as seperate columns. Also i would need the file name as the header for each column where the value was copied from
xls files are the file type
CodePudding user response：
Try this.
Sub FromAllFilesIntoColumns()
Dim MyPath As String, FilesInPath As String
Dim MyFiles() As String
Dim SourceCcount As Long, Fnum As Long
Dim mybook As Workbook, BaseWks As Worksheet
Dim sourceRange As Range, destrange As Range
Dim Cnum As Long, CalcMode As Long
'Fill in the path\folder where the files are
MyPath = "C:\Users\Ron\test"
'Add a slash at the end if the user forget it
If Right(MyPath, 1) <> "\" Then
MyPath = MyPath & "\"
End If
'If there are no Excel files in the folder exit the sub
FilesInPath = Dir(MyPath & "*.xl*")
If FilesInPath = "" Then
MsgBox "No files found"
Exit Sub
End If
'Fill the array(myFiles)with the list of Excel files in the folder
Fnum = 0
Do While FilesInPath <> ""
Fnum = Fnum 1
ReDim Preserve MyFiles(1 To Fnum)
MyFiles(Fnum) = FilesInPath
FilesInPath = Dir()
Loop
'Change ScreenUpdating, Calculation and EnableEvents
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With
'Add a new workbook with one sheet
Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
Cnum = 1
'Loop through all files in the array(myFiles)
If Fnum > 0 Then
For Fnum = LBound(MyFiles) To UBound(MyFiles)
Set mybook = Nothing
On Error Resume Next
Set mybook = Workbooks.Open(MyPath & MyFiles(Fnum))
On Error GoTo 0
If Not mybook Is Nothing Then
On Error Resume Next
Set sourceRange = mybook.Worksheets(1).Range("A1:A10")
If Err.Number > 0 Then
Err.Clear
Set sourceRange = Nothing
Else
'if SourceRange use all rows then skip this file
If sourceRange.Rows.Count >= BaseWks.Rows.Count Then
Set sourceRange = Nothing
End If
End If
On Error GoTo 0
If Not sourceRange Is Nothing Then
SourceCcount = sourceRange.Columns.Count
If Cnum SourceCcount >= BaseWks.Columns.Count Then
MsgBox "Sorry there are not enough columns in the sheet"
BaseWks.Columns.AutoFit
mybook.Close savechanges:=False
GoTo ExitTheSub
Else
'Copy the file name in the first row
With sourceRange
BaseWks.cells(1, Cnum). _
Resize(, .Columns.Count).Value = MyFiles(Fnum)
End With
'Set the destrange
Set destrange = BaseWks.cells(2, Cnum)
'we copy the values from the sourceRange to the destrange
With sourceRange
Set destrange = destrange. _
Resize(.Rows.Count, .Columns.Count)
End With
destrange.Value = sourceRange.Value
Cnum = Cnum SourceCcount
End If
End If
mybook.Close savechanges:=False
End If
Next Fnum
BaseWks.Columns.AutoFit
End If
ExitTheSub:
'Restore ScreenUpdating, Calculation and EnableEvents
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalcMode
End With
End Sub
CodePudding user response：
Import Columns
Sub ImportColumns()
' Define constants.
Const SOURCE_FOLDER_PATH As String = "C:\Test"
Const SOURCE_WORKSHEET_ID As Variant = 1 ' the first (you say: 'and only')
Const SOURCE_FIRST_CELL_ADDRESS As String = "A2"
Const SOURCE_FILE_PATTERN As String = "*.xls" ' only `.xls`
Const DESTINATION_WORKSHEET_NAME As String = "Master"
Const DESTINATION_FIRST_CELL_ADDRESS As String = "A1"
' Write the source file paths to a collection.
Dim pSep As String: pSep = Application.PathSeparator
Dim sPath As String: sPath = SOURCE_FOLDER_PATH
If Right(sPath, 1) <> pSep Then sPath = sPath & pSep
Dim sFolderName As String: sFolderName = Dir(sPath, vbDirectory)
If Len(sFolderName) = 0 Then
MsgBox "The path '" & sPath & "' doesn't exist.", vbExclamation
Exit Sub
End If
Dim sDirPattern As String: sDirPattern = sPath & SOURCE_FILE_PATTERN
Dim sFileName As String: sFileName = Dir(sDirPattern)
If Len(sFileName) = 0 Then
MsgBox "No '" & SOURCE_FILE_PATTERN & "' files found in '" _
& sPath & "'.", vbExclamation
Exit Sub
End If
Dim coll As Collection: Set coll = New Collection
Do While Len(sFileName) > 0
coll.Add sPath & sFileName
sFileName = Dir
Loop
Application.ScreenUpdating = False
' Write data to a jagged array:
' - the 1st column will hold the headers (file name without extension)
' - the 2nd column will hold the source number of rows
' for the final inner loop i.e. 'For dr = 1 To dJag(c, 2)';
' this row number is used anyway, to determine the number
' of destination rows.
' - the 3rd column will hold an array with the source range values
Dim dcCount As Long: dcCount = coll.Count
Dim dJag As Variant: ReDim dJag(1 To dcCount, 1 To 3)
Dim OneCell As Variant: ReDim OneCell(1 To 1, 1 To 1) ' if one cell
Dim swb As Workbook
Dim sws As Worksheet
Dim srg As Range
Dim sfCell As Range
Dim slCell As Range
Dim srCount As Long
Dim swbName As String
Dim drCount As Long
Dim Item As Variant
Dim c As Long
For Each Item In coll
c = c 1
Set swb = Workbooks.Open(Item, True, True)
swbName = swb.Name
' Write file name without extension.
dJag(c, 1) = Left(swbName, InStrRev(swbName, ".") - 1)
Set sws = swb.Worksheets(SOURCE_WORKSHEET_ID)
If sws.FilterMode Then sws.ShowAllData
Set sfCell = sws.Range(SOURCE_FIRST_CELL_ADDRESS)
Set slCell = sfCell.Resize(sws.Rows.Count - sfCell.Row 1) _
.Find("*", , xlFormulas, , , xlPrevious)
If Not slCell Is Nothing Then
Set srg = sws.Range(sfCell, slCell)
srCount = srg.Rows.Count
If srCount > drCount Then drCount = srCount ' determine max row
' Write number of rows.
dJag(c, 2) = srCount
' Write data.
If srCount = 1 Then ' one cell in column
OneCell(1, 1) = srg.Value
dJag(c, 3) = OneCell
Else ' multiple cells in column
dJag(c, 3) = srg.Value
End If
'Else ' no data in column; do nothing
End If
swb.Close SaveChanges:=False ' just reading
Next Item
Set coll = Nothing ' data is in 'dJag'
drCount = drCount 1 ' 1 for headers
' Write the data from the jagged array to the destination array.
Dim dData() As Variant: ReDim dData(1 To drCount, 1 To dcCount)
Dim dr As Long
For c = 1 To dcCount
' Write header.
dData(1, c) = dJag(c, 1)
' Write data.
If Not IsEmpty(dJag(c, 2)) Then
For dr = 1 To dJag(c, 2)
dData(dr 1, c) = dJag(c, 3)(dr, 1) ' 1 due to headers
Next dr
'Else ' no data in column; do nothing
End If
Next c
Erase dJag ' data is in 'dData'
' Write the data from the destination array to the destination range.
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)
Dim drg As Range: Set drg = dfCell.Resize(drCount, dcCount)
drg.Value = dData
Application.ScreenUpdating = True
MsgBox "Columns imported.", vbInformation
End Sub