我已搜索并搜索代码问题的答案，但找不到任何答案。如果有人可以看一下我的代码，我将不胜感激。目前，我有几本针对每个国家/地区的数据的大型工作簿。每个工作簿都有5个以上的工作表。我想将工作簿合并到一个主文件中。首先，我要复制所有工作表并将其粘贴到主工作簿的一个工作表下，并按国家/地区命名。现在，我的代码一次只能合并一个国家/地区，这使其非常慢。循环工作表似乎也失败了。它仅创建一个国家/地区工作表。如果输入多个国家/地区名称，则仅合并最后一个国家/地区工作簿。缺少了一些东西，但我似乎无法弄清楚。非常感谢！！！！下面是我的代码：
Sub consolidate()
Application.EnableCancelKey = xlDisabled
Dim folderPath As String
Dim Filename As String
Dim wb As Workbook
Dim Masterwb As Workbook
Dim sh As Worksheet
Dim NewSht As Worksheet
Dim FindRng As Range
Dim PasteRow As Long
Dim countryname As String
Dim LastRow, Rowlast, Rowlast2 As Long
Const fr As Long = 2
Dim i As Long
Dim cell As Range
Dim wx As Worksheet
Set wx = ThisWorkbook.Sheets("Countryname")
Rowlast = wx.Range("B" & Rows.Count).End(xlDown).row 'selects list of country workbook I want to consolidate. e.g I could have Germany, usa, china
Rowlast2 = wx.Range("C" & Rows.Count).End(xlDown).row 'selects list of tabs for each country workbook I want to consolidate, e.g I want for every country listed above, that sheet names 1, 2, 3, 4 be consolidated and put in new worksheets in the masterfile
With wx
For LastRow = fr To Rowlast
If .Cells(LastRow, "B").Value <> "" Then
countryname = .Cells(LastRow, "B").Value
' set master workbook
Set Masterwb = Workbooks("ebele_test.xlsm")
folderPath = Application.InputBox(Prompt:= _
"Please enter only folder path in this format as C:\Users\... Exclude the file name", _
Title:="InputBox Method", Type:=2) 'Type:=2 = text
If folderPath = "False" Or IsError(folderPath) Then 'If Cancel is clicked on Input Box exit sub
MsgBox "Incorrect Input, Please paste correct folder path"
Exit Sub
'On Error GoTo 0
End If
If Right(folderPath, 1) <> "\" Then folderPath = folderPath & "\"
Application.ScreenUpdating = False
Dim str As String
str = "Screener_User_Template-"
Filename = Dir(folderPath & str & countryname & "*.xlsx")
Do While Filename <> ""
Set wb = Workbooks.Open(folderPath & Filename)
If Len(wb.Name) > 253 Then
MsgBox "Sheet's name can be up to 253 characters long, shorten the Excel file name"
wb.Close False
GoTo Exit_Loop
Else
' add a new sheet with the file's name (remove the extension)
With Masterwb
Dim isLastSheet As Boolean
Dim ci, rows1 As Integer
Dim row As Long
rows1 = ThisWorkbook.Worksheets.Count
For ci = rows1 To 1 Step (-1)
If (isLastSheet) = False Then
Set NewSht = Masterwb.Worksheets.Add(After:=Worksheets(ci)) 'Place sheet at the end.
NewSht.Cells(1, 1) = "Identifier"
NewSht.Cells(1, 2) = "Company Name"
NewSht.Cells(1, 3) = "Country of Incorporation"
NewSht.Name = countryname
End If
Next ci
End With
End If
' loop through all sheets in opened wb
For Each sh In wb.Worksheets
For i = 2 To Rowlast2
If sh.Name = wx.Cells(i, "C").Value And NewSht.Name = countryname Then
' get the first empty row in the new sheet
Set FindRng = NewSht.Cells.Find(What:="*", Lookat:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False)
If Not FindRng Is Nothing Then ' If find is successful
PasteRow = FindRng.row + 1
Else ' find was unsuccessfull > new empty sheet, should paste at the second row
PasteRow = 2
End If
Dim rng As Range
Set rng = sh.Range(sh.Cells(3, "A"), sh.Cells(150000, "M"))
rng.Copy
NewSht.Range("A" & PasteRow).PasteSpecial xlPasteValues
End If
Application.CutCopyMode = False 'Clears the clipboard
Next i
Next sh
wb.Close False
Exit_Loop:
Set wb = Nothing
Filename = Dir
Loop
End If
Next LastRow
End With
'0: Exit Sub
Application.ScreenUpdating = True
End Sub
答案 0 :(得分：0)
这不是解决方案，只是一项正在进行的工作，由于缺乏信息和知识，我无法继续。它可以帮助您完成开始的工作。在您花了很多时间之后退出，这将是可耻的。如果您从代码中的问题中得到一些答案，则可能会有其他人帮助您完成它。这些问题绝不是讽刺的，它们是我不能肯定回答的严肃问题。
该代码应该是安全的，但不要保存任何内容以免丢失数据。
我建议您以某种方式将这样的代码分成几个部分，并提出几个问题以在将来获得答案。
Option Explicit
Sub Consolidate()
Application.EnableCancelKey = xlDisabled
' ThisWorkbook
Const cStrCountry As String = "CountryName"
Const cLngRow1 As Long = 2
' Tip: To use columns either as string or as integer declare them as Variant.
Const cVntColCountries As Variant = "B"
Const cVntColTabs As Variant = "C"
Const cStrTemplate = "Screener_User_Template-"
Const cStrMaster As String = "ebele_test.xlsm"
Const cStrExt = ".xlsx"
' New Worksheet in Master Workbook
Const cStrNewHeader1 = "Identifier"
Const cStrNewHeader2 = "Company Name"
Const cStrNewHeader3 = "Country of Incorporation"
' Each Worksheet in Each Workbook
Const cLngFirstRow As Long = 3
Const cLngLastRow As Long = 150000
' Tip: To use columns either as string or as integer declare them as Variant.
Const cVntFirstCol As Variant = "A"
Const cVntLastCol As Variant = "M"
' MsgBox
Dim strMsg1 As String
strMsg1 = "Please enter only folder path in this format as " _
& "C:\Users\... Exclude the file name"
Dim strMsg2 As String
strMsg2 = "Incorrect Input. Please paste correct folder path."
Dim strMsg3 As String
strMsg3 = "Sheet's name can only be up to 253 characters long. " _
& "Shorten the Excel file name."
' Workbooks
' ThisWorkbook
Dim ojbWbEach As Workbook ' Workbook Looper
Dim objWbMaster As Workbook ' Master Workbook
' Worksheets
' ThisWorkbook.Worksheets (cStrCountry)
Dim objWsEach As Worksheet ' Worksheet Looper
Dim objWsNew As Worksheet ' New Worksheet
' Arrays Pasted From Ranges
Dim vntCountries As Variant ' List of Countries
Dim vntTabs As Variant ' List of Tabs
' Ranges
Dim objRngEmpty As Range ' New Sheet Paste Cell
' Rows
Dim lngPasteRow As Long ' New Sheet Paste Row
Dim lngCountries As Long ' Countries Counter
Dim lngTabs As Long ' Tabs Counter
' Strings
Dim strPath As String
Dim strFile As String
Dim strCountry As String
With ThisWorkbook.Worksheets(cStrCountry)
' Paste list of countries from column cVntColCountries into array
vntCountries = .Range(.Cells(cLngRow1, cVntColCountries), _
.Cells(Rows.Count, cVntColCountries).End(xlUp)).Value2
' Paste list of tabs from column cVntColTabs into array
vntTabs = .Range(.Cells(cLngRow1, cVntColTabs), _
.Cells(Rows.Count, cVntColTabs).End(xlUp)).Value2
End With
' The data is in arrays instead of ranges.
' 1. According to the following line the workbook objWbMaster is already open.
' Is that true?
Set objWbMaster = Workbooks(cStrMaster)
For lngCountries = LBound(vntCountries) To UBound(vntCountries)
If vntCountries(lngCountries, 1) <> "" Then
strCountry = vntCountries(lngCountries, 1)
' Determine the path to search for files in.
strPath = Application.InputBox(Prompt:=strMsg1, _
Title:="InputBox Method", Type:=2) ' Type:=2 = text
' When Cancel is clicked in Input Box ... Exit Sub
If strPath = "False" Or IsError(strPath) Then
MsgBox strMsg2
Exit Sub
End If
If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
Application.ScreenUpdating = False
strFile = Dir(strPath & cStrTemplate & strCountry & "*" & cStrExt)
' VBA Help: Dir returns the first file name that matches pathname. To
' get any additional file names that match pathname, call Dir
' again with no arguments. When no more file names match, Dir
' returns a zero-length string ("").
' i.e. The approach is correct!
Do While strFile <> ""
Set ojbWbEach = Workbooks.Open(strPath & strFile)
' 2. When would this ever happen?
If Len(ojbWbEach.Name) <= 253 Then
' Add a new sheet with the file's name (remove the extension)
With objWbMaster
' 3. Isn't the blnLastSheet always False. What should it be doing?
Dim blnLastSheet As Boolean
Dim intSheetsCounter As Integer
Dim intSheets As Integer
intSheets = .Worksheets.Count
' 4. Why parentheses in ... Step (-1)?
For intSheetsCounter = intSheets To 1 Step -1
' 5. Why parentheses in (blnLastSheet)?
If (blnLastSheet) = False Then
' Place sheet at the end.
Set objWsNew = .Worksheets _
.Add(After:=.Worksheets(intSheetsCounter))
With objWsNew
.Cells(1, 1) = cStrNewHeader1
.Cells(1, 2) = cStrNewHeader2
.Cells(1, 3) = cStrNewHeader3
.Name = strCountry
End With
End If
Next
End With
Else
MsgBox strMsg3
ojbWbEach.Close False
GoTo Exit_Loop
End If
' Loop through all worksheets in ojbWbEach.
For Each objWsEach In ojbWbEach.Worksheets
With objWsEach
For lngTabs = LBound(vntTabs) To UBound(vntTabs)
If .Name = vntTabs(lngTabs) _
And objWsNew.Name = strCountry Then
' Get the first empty row in the new sheet
Set objRngEmpty = objWsNew.Cells.Find(What:="*", _
Lookat:=xlPart, LookIn:=xlFormulas, _
SearchOrder:=xlByRows, SearchDirection:=xlPrevious)
' 6. I don't think that this is necessary because you added
' the headers to the New sheet so it will find the first
' row. Or am I missing something?
If Not objRngEmpty Is Nothing Then
' If find is successful.
lngPasteRow = objRngEmpty.row + 1
Else
' Find was unsuccessfull > new empty sheet.
' Should paste at the second row.
lngPasteRow = cLngRow1
End If
' if I'm right, delete all starting from "Set objRngEmpty ..."
' and delete "Dim objRngEmpty as Range" and use the following
' line:
' lngPasteRow = objWsNew.Cells.Find(What:="*", Lookat:=xlPart, _
LookIn:=xlFormulas, SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).row + 1
' Pasting a range into a same sized range is much faster than
' looping or copy/pasting.
objWsNew.Range(.Cells(lngPasteRow, cVntFirstCol), _
.Cells(cLngLastRow + lngPasteRow - cLngFirstRow, _
cVntLastCol)) = _
.Range(.Cells(cLngFirstRow, cVntFirstCol), _
.Cells(cLngLastRow, cVntLastCol)).Value2
End If
Next
.Close False
End With
Next
Exit_Loop:
Set ojbWbEach = Nothing
strFile = Dir
Loop
End If
Next lngCountries
Set objWsEach = Nothing
Set objWsNew = Nothing
Set objWbEach = Nothing
Set objWbMaster = Nothing
Application.ScreenUpdating = True
End Sub
答案 1 :(得分：0)
再次感谢您的清理。我对您的代码进行了一些修改并纠正了一些错误，但是由于某些原因，它只能合并7个国家/地区，之后excel崩溃。请参阅下面运行的代码：您认为可以找到问题吗？
显式选项
Sub Consolidate()
Application.EnableCancelKey = xlDisabled
' ThisWorkbook
Const cStrCountry As String = "CountryName"
Const cLngRow1 As Long = 2
' Tip: To use columns either as string or as integer declare them as Variant.
Const cVntColCountries As Variant = "B"
Const cVntColTabs As Variant = "C"
Const cStrTemplate = "Screener_User_Template-"
Const cStrMaster As String = "ebele_test.xlsm"
Const cStrExt = ".xlsx"
' New Worksheet in Master Workbook
Const cStrNewHeader1 = "Identifier"
Const cStrNewHeader2 = "Company Name"
Const cStrNewHeader3 = "Country of Incorporation"
' Each Worksheet in Each Workbook
Const cLngFirstRow As Long = 3
Const cLngLastRow As Long = 150000
' Tip: To use columns either as string or as integer declare them as Variant.
Const cVntFirstCol As Variant = "A"
Const cVntLastCol As Variant = "M"
' MsgBox
Dim strMsg1 As String
strMsg1 = "Please enter only folder path in this format as " _
& "C:\Users\... Exclude the file name"
Dim strMsg2 As String
strMsg2 = "Incorrect Input. Please paste correct folder path."
Dim strMsg3 As String
strMsg3 = "Sheet's name can only be up to 253 characters long. " _
& "Shorten the Excel file name."
' Workbooks
' ThisWorkbook
Dim ojbWbEach As Workbook ' Workbook Looper
Dim objWbMaster As Workbook ' Master Workbook
' Worksheets
' ThisWorkbook.Worksheets (cStrCountry)
Dim objWsEach As Worksheet ' Worksheet Looper
Dim objWsNew As Worksheet ' New Worksheet
' Arrays Pasted From Ranges
Dim vntCountries As Variant ' List of Countries
Dim vntTabs As Variant ' List of Tabs
' Ranges
Dim objRngEmpty As Range ' New Sheet Paste Cell
' Rows
Dim lngPasteRow As Long ' New Sheet Paste Row
Dim lngCountries As Long ' Countries Counter
Dim lngTabs As Long ' Tabs Counter
' Strings
Dim strPath As String
Dim strFile As String
Dim strCountry As String
With ThisWorkbook.Worksheets(cStrCountry)
' Paste list of countries from column cVntColCountries into array
vntCountries = .Range(.Cells(cLngRow1, cVntColCountries), _
.Cells(Rows.Count, cVntColCountries).End(xlUp)).Value2
' Paste list of tabs from column cVntColTabs into array
vntTabs = .Range(.Cells(cLngRow1, cVntColTabs), _
.Cells(Rows.Count, cVntColTabs).End(xlUp)).Value2
End With
' The data is in arrays instead of ranges.
' 1. According to the following line the workbook objWbMaster is already open.
' Is that true? yeah, but I moved the strpath up because I want it to be inputed once
Set objWbMaster = Workbooks(cStrMaster)
' Determine the path to search for files in.
strPath = Application.InputBox(Prompt:=strMsg1, _
Title:="InputBox Method", Type:=2) ' Type:=2 = text
'
For lngCountries = LBound(vntCountries) To UBound(vntCountries)
If vntCountries(lngCountries, 1) <> "" And strPath <> "" Then
strCountry = vntCountries(lngCountries, 1)
' When Cancel is clicked in Input Box ... Exit Sub
If strPath = "False" Or IsError(strPath) Then
MsgBox strMsg2
Exit Sub
End If
If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
Application.ScreenUpdating = False
strFile = Dir(strPath & cStrTemplate & strCountry & "*" & cStrExt)
' VBA Help: Dir returns the first file name that matches pathname. To
' get any additional file names that match pathname, call Dir
' again with no arguments. When no more file names match, Dir
' returns a zero-length string ("").
' i.e. The approach is correct!
Do While strFile <> ""
Set ojbWbEach = Workbooks.Open(strPath & strFile)
' 2. When would this ever happen?
If Len(ojbWbEach.Name) <= 253 Then
' Add a new sheet with the file's name (remove the extension)
With objWbMaster
' 3. Isn't the blnLastSheet always False. What should it be doing?
Dim blnLastSheet As Boolean
Dim intSheetsCounter As Integer
Dim intSheets As Integer
intSheets = .Worksheets.Count
' 4. Why parentheses in ... Step (-1)?
For intSheetsCounter = intSheets To 1 Step -1
' 5. Why parentheses in (blnLastSheet)?
If blnLastSheet = False Then
' Place sheet at the end.
Set objWsNew = .Worksheets _
.Add(After:=.Worksheets(intSheetsCounter))
With objWsNew
.Cells(1, 1) = cStrNewHeader1
.Cells(1, 2) = cStrNewHeader2
.Cells(1, 3) = cStrNewHeader3
End With
End If
Next
End With
Else
MsgBox strMsg3
ojbWbEach.Close False
GoTo Exit_Loop
End If
' Loop through all worksheets in ojbWbEach.
For Each objWsEach In ojbWbEach.Worksheets
With objWsEach
For lngTabs = LBound(vntTabs) To UBound(vntTabs)
If .Name = vntTabs(lngTabs, 1) Then
' _
'And objWsNew.Name = strCountry
'
' Get the first empty row in the new sheet
lngPasteRow = objWsNew.Cells.Find(What:="*", Lookat:=xlPart, _
LookIn:=xlFormulas, SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).row + 1
' Pasting a range into a same sized range is much faster than
' looping or copy/pasting.
objWsNew.Range(objWsNew.Cells(lngPasteRow, cVntFirstCol), _
objWsNew.Cells(cLngLastRow + lngPasteRow - cLngFirstRow, _
cVntLastCol)) = _
.Range(.Cells(cLngFirstRow, cVntFirstCol), _
.Cells(cLngLastRow, cVntLastCol)).Value2
objWsNew.Name = strCountry
End If
Next
End With
Next
ojbWbEach.Close False
Exit_Loop:
Set ojbWbEach = Nothing
strFile = Dir
Loop
End If
Next lngCountries
Set objWsEach = Nothing
Set objWsNew = Nothing
Set ojbWbEach = Nothing
Set objWbMaster = Nothing
Call Module2.clean
Application.ScreenUpdating = True
End Sub
它的作用是，它还会创建额外的空白工作表，我必须使用子清理来清理这些工作表。
答案 2 :(得分：-1)
这是我的整合者提供的代码，也许您会有所想法。
<div class="background" id="back">
<img src="https://www.gettyimages.co.uk/gi-resources/images/CreativeLandingPage/HP_Sept_24_2018/CR3_GettyImages-159018836.jpg"/>
</div>