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
CodePudding user response：
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
CodePudding user response：
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