【发布时间】：2020-03-08 16:43:51
【问题描述】：
我已经搜索并搜索了我的代码问题的答案，但我找不到任何答案。如果有人可以查看我的代码，我将不胜感激。目前，我有几个大型工作簿，用于每个国家/地区的数据。每个工作簿有超过 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
【问题讨论】：
-
这是需要通读的大量代码。你能解释一下你的代码要完成的一般步骤吗
-
wx.Range("B" & Rows.Count).End(xlDown).row这看起来不对，我想你想要wx.Range("B" & wx.Rows.Count).End(xlup).row，与“C”列相同 -
@O.PAL：“Application.Rows.Count”、“Rows.Count”和“wx.Rows.Count”都返回相同的数字。总结：“Rows.Count”很好。不过，您对“xlUp”的看法是正确的。
-
这里没有足够的信息供任何人提供逻辑错误的解决方案。我们可以指出其他语法错误或编码中可能出现的混淆，例如您的行
Dim LastRow, Rowlast, Rowlast2 As Long。你实际上只是声明Rowlast2。前两个变量未指定，默认输入Variant