此代码旨在扩展从多个源导入复制数据并粘贴到主表中的上下文。它还可以通过从内部主文件复制和粘贴，然后使用它来扩展新范围来实现。
Sub newloopfilemodule()
Dim wb As Workbook
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim FldrPicker As FileDialog
'First clear any original data
Sheet1.Rows("2:50").ClearContents
'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 (must include wildcard "*")
myExtension = "*.xls*"
'Target Path with Ending Extention
myFile = Dir(myPath & myExtension)
'Loop through each Excel file in folder
Do While myFile <> ""
'Set variable equal to opened workbook
Set wb = Workbooks.Open(Filename:=myPath & myFile)
'Ensure Workbook has opened before moving on to next line of code
DoEvents
'Identify column number for Customer Parent ID, Country, and Region
Dim custParentIDCol As Integer, custcidcol As Integer, customernamecol As Integer
custParentIDCol = WorksheetFunction.Match("Customer Parent ID", wb.Sheets(1).Rows(1), 0)
custcidcol = WorksheetFunction.Match("Customer CID", wb.Sheets(1).Rows(1), 0)
customernamecol = WorksheetFunction.Match("Customer Name", wb.Sheets(1).Rows(1), 0)
'Count total number of rows in raw data file
Dim rowNum As Integer
rowNum = 2
Dim topClients As String
Dim filenamenow As String
filenamenow = Mid(myFile, 1, InStr(1, myFile, ".") - 1)
Dim outputrownum As Integer
outputrownum = WorksheetFunction.CountA(Sheet1.Range("A:A"))
outputrownum = outputrownum + 1
Do While IsEmpty(wb.Sheets(1).Cells(rowNum, custParentIDCol)) = False
If WorksheetFunction.CountIf(wb.Sheets(1).Range(wb.Sheets(1).Cells(2, custParentIDCol), wb.Sheets(1).Cells(rowNum, custParentIDCol)), _
wb.Sheets(1).Cells(rowNum, custParentIDCol)) = 1 Then
Sheet1.Cells(outputrownum, 1) = outputrownum - 1
Sheet1.Cells(outputrownum, 2) = filenamenow
Sheet1.Cells(outputrownum, 3) = wb.Sheets(1).Cells(rowNum, custParentIDCol)
Sheet1.Cells(outputrownum, 4) = wb.Sheets(1).Cells(rowNum, custcidcol)
Sheet1.Cells(outputrownum, 5) = wb.Sheets(1).Cells(rowNum, customernamecol)
If WorksheetFunction.CountIf(Sheet2.Columns(1), wb.Sheets(1).Cells(rowNum, custParentIDCol)) > 0 Then
topClients = WorksheetFunction.VLookup(wb.Sheets(1).Cells(rowNum, custParentIDCol), Sheet2.Range("A:B"), 2, 0)
Sheet1.Cells(outputrownum, 6).Value = topClients
End If
outputrownum = outputrownum + 1
End If
rowNum = rowNum + 1
Loop
'Save and Close Workbook
wb.Close SaveChanges:=True
'Ensure Workbook has closed before moving on to next line of code
DoEvents
'Get next file name
myFile = Dir
Loop
'Reset Macro Optimization Settings
ResetSettings:
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
Sub combinedata()
Dim projecttitlecol As Integer, effectivedatecol As Integer, productcol As Integer, matchingproject As Integer
projecttitlecol = WorksheetFunction.Match("Project Title", Sheet3.Rows(1), 0)
effectivedatecol = WorksheetFunction.Match("Effective Date", Sheet3.Rows(1), 0)
productcol = WorksheetFunction.Match("Product", Sheet3.Rows(1), 0)
Dim rowNum As Integer
rowNum = 2
Do While IsEmpty(Sheet1.Cells(rowNum, 2)) = False
If WorksheetFunction.CountIf(Sheet3.Columns(1), Sheets(1).Cells(rowNum, 2)) > 0 Then
matchingproject = WorksheetFunction.Match(Sheet1.Cells(rowNum, 2), Sheet3.Columns(1), 0)
Sheet1.Cells(rowNum, 7) = Sheet3.Cells(matchingproject, projecttitlecol)
Sheet1.Cells(rowNum, 8) = Sheet3.Cells(matchingproject, effectivedatecol)
Sheet1.Cells(rowNum, 9) = Sheet3.Cells(matchingproject, productcol)
End If
rowNum = rowNum + 1
Loop
End Sub
答案 0 :(得分：0)
Sub LoopAllExcelFilesInFolder()
Dim wb As Workbook
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim FldrPicker As FileDialog
'First clear any original data
Sheet1.Rows("2:20").ClearContents
'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 (must include wildcard "*")
myExtension = "*.xls*"
'Target Path with Ending Extention
myFile = Dir(myPath & myExtension)
'Loop through each Excel file in folder
Do While myFile <> ""
'Set variable equal to opened workbook
Set wb = Workbooks.Open(Filename:=myPath & myFile)
'Ensure Workbook has opened before moving on to next line of code
DoEvents
'Identify column number for Customer Parent ID, Country, and Region
Dim custParentIDCol As Integer, countryCol As Integer, regionCol As Integer
custParentIDCol = WorksheetFunction.Match("UltimateID", wb.Sheets(1).Rows(1), 0)
countryCol = WorksheetFunction.Match("ClntCntryCode", wb.Sheets(1).Rows(1), 0)
regionCol = WorksheetFunction.Match("DomicileRegion", wb.Sheets(1).Rows(1), 0)
ultimatenameCol = WorksheetFunction.Match("UltimateName", wb.Sheets(1).Rows(1), 0)
'Count total number of rows in raw data file
Dim rowNum As Integer
rowNum = 2
Do Until IsEmpty(wb.Sheets(1).Cells(rowNum, 1)) = True
rowNum = rowNum + 1
Loop
rowNum = rowNum - 1
wb.Sheets(1).Columns(custParentIDCol).Select 'specify the range which suits your purpose
With Selection
Selection.NumberFormat = "General"
.Value = .Value
End With
'Count total number of unique clients impacted by project. If a client is APAC, count it.
'If a client is unique, check if it's a top client. Add country.
Dim totUniqueClients As Integer
Dim totUniqueClientsAPAC As Integer
Dim topClients As String
Dim countries As String
totUniqueClients = 0
totUniqueClientsAPAC = 0
topClients = ""
countries = ""
'Sort ultimate name by A to Z
Sheets(1).AutoFilter.Sort.SortFields.Clear
Sheets(1).AutoFilter.Sort.SortFields.Add Key:=Columns(ultimatenameCol), SortOn:=xlSortOnValues, Order:=xlAscending, _
DataOption:=xlSortNormal
With Sheets(1).AutoFilter.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
For x = 2 To rowNum
'Use COUNTIF to check if its a unique client. If unique, then add to totUniqueClient count.
If WorksheetFunction.CountIf(wb.Sheets(1).Range(wb.Sheets(1).Cells(2, custParentIDCol), wb.Sheets(1).Cells(x, custParentIDCol)), _
wb.Sheets(1).Cells(x, custParentIDCol)) = 1 Then
totUniqueClients = totUniqueClients + 1
'Then check if its APAC. If APAC, then add to totUniqueClientAPAC count
If wb.Sheets(1).Cells(x, regionCol) = "ASIA" Then
totUniqueClientsAPAC = totUniqueClientsAPAC + 1
End If
'Then check if its a top client. If so, then add to topClient amount.
If WorksheetFunction.CountIf(Sheet2.Columns(1), wb.Sheets(1).Cells(x, custParentIDCol)) > 0 Then
If Len(topClients) > 0 Then
topClients = topClients & ", " & WorksheetFunction.VLookup(wb.Sheets(1).Cells(x, custParentIDCol), Sheet2.Range("A1:D27"), 4, 0)
Else
topClients = WorksheetFunction.VLookup(wb.Sheets(1).Cells(x, custParentIDCol), Sheet2.Range("A:D"), 4, 0)
End If
End If
End If
Next
'Sort Country by A to Z
Sheets(1).AutoFilter.Sort.SortFields.Clear
Sheets(1).AutoFilter.Sort.SortFields.Add Key:=Columns(countryCol), SortOn:=xlSortOnValues, Order:=xlAscending, _
DataOption:=xlSortNormal
With Sheets(1).AutoFilter.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
For x = 2 To rowNum
'Use COUNTIF to check if its a unique country. If unique, then add to list of countries.
If WorksheetFunction.CountIf(wb.Sheets(1).Range(wb.Sheets(1).Cells(2, countryCol), wb.Sheets(1).Cells(x, countryCol)), _
wb.Sheets(1).Cells(x, countryCol)) = 1 Then
If wb.Sheets(1).Cells(x, regionCol) = "ASIA" Then
If Len(countries) > 0 Then
countries = countries & ", " & wb.Sheets(1).Cells(x, countryCol)
Else
countries = wb.Sheets(1).Cells(x, countryCol)
End If
End If
End If
Next
'Populate table in masterfile
Dim tableRow As Integer
tableRow = WorksheetFunction.CountA(Sheet1.Range("A:A"))
tableRow = tableRow + 1
Sheet1.Cells(tableRow, 1) = tableRow - 1
Sheet1.Cells(tableRow, 2) = myFile
Sheet1.Cells(tableRow, 3) = totUniqueClients
Sheet1.Cells(tableRow, 4) = totUniqueClientsAPAC
Sheet1.Cells(tableRow, 5) = topClients
Sheet1.Cells(tableRow, 6) = countries
'Save and Close Workbook
wb.Close SaveChanges:=True
'Ensure Workbook has closed before moving on to next line of code
DoEvents
'Get next file name
myFile = Dir
Loop
'Reset Macro Optimization Settings
ResetSettings:
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub