用于将所有工作表的前两列复制到主工作表的宏将跳过工作表

Question

我正在使用此宏将所有工作表中的列A和B复制到名为Master的新工作表中。我注意到，在主表中缺少整张信息，我找不到原因。我的工作表的格式是A列有一个字符串，它遵循以下结构：M2,004,005,004,007,17,096,01：07：45,45和B列仅仅是一个日期，如2017年4月19日。

我在工作簿中有数百张这些图纸，每张图都有224行，我需要将其复制到一张主图纸中。任何人都可以帮我弄清楚如何让这段代码停止跳页？

谢谢。

Sub CreateMaster() 

Dim J As Integer 

On Error Resume Next 

Sheets(1).Select 

Worksheets.Add 

Sheets(1).Name = "Master" 

Sheets(2).Activate 

Range("A1:B1").EntireRow.Select 

Selection.Copy Destination:=Sheets(1).Range("A1:B1") 

For J = 2 To Sheets.Count 

Sheets(J).Activate 

Range("A1:B1").Select 

Selection.CurrentRegion.Select 

Selection.Copy Destination:=Sheets(1).Range("A65536:B65536").End(xlUp)(2) 

Next 

End Sub 

同时在线寻找解决方案，我遇到了这个宏，似乎做同样的事情，也似乎为我的宏不跳过完全相同的床单。

子CopyFromWorksheets（）

Dim wrk As Workbook 'Workbook object - Always good to work with object 

变量

Dim sht As Worksheet 'Object for handling worksheets in loop 

Dim trg As Worksheet 'Master Worksheet 

Dim rng As Range 'Range object 

Dim colCount As Integer 'Column count in tables in the worksheets 

Set wrk = ActiveWorkbook 'Working in active workbook 

For Each sht In wrk.Worksheets 
    If sht.Name = "Master" Then 
     MsgBox "There is a worksheet called as 'Master'." & vbCrLf & _ 
     "Please remove or rename this worksheet since 'Master' would be" & _ 
     "the name of the result worksheet of this process.", vbOKOnly + vbExclamation, "Error" 
     Exit Sub 
    End If 
Next sht 

'We don't want screen updating 
Application.ScreenUpdating = False 

'Add new worksheet as the last worksheet 
Set trg = wrk.Worksheets.Add(After:=wrk.Worksheets(wrk.Worksheets.Count)) 
'Rename the new worksheet 
trg.Name = "Master" 
'Get column headers from the first worksheet 
'Column count first 
Set sht = wrk.Worksheets(1) 
colCount = sht.Cells(1, 255).End(xlToLeft).Column 
'Now retrieve headers, no copy&paste needed 
With trg.Cells(1, 1).Resize(1, colCount) 
    .Value = sht.Cells(1, 1).Resize(1, colCount).Value 
    'Set font as bold 
    .Font.Bold = True 
End With 

'We can start loop 
For Each sht In wrk.Worksheets 
    'If worksheet in loop is the last one, stop execution (it is Master worksheet) 
    If sht.Index = wrk.Worksheets.Count Then 
     Exit For 
    End If 
    'Data range in worksheet - starts from second row as first rows are the header rows in all worksheets 
    Set rng = sht.Range(sht.Cells(2, 1), sht.Cells(65536, 1).End(xlUp).Resize(, colCount)) 
    'Put data into the Master worksheet 
    trg.Cells(65536, 1).End(xlUp).Offset(1).Resize(rng.Rows.Count, rng.Columns.Count).Value = rng.Value 
Next sht 
'Fit the columns in Master worksheet 
trg.Columns.AutoFit 

'Screen updating should be activated 
Application.ScreenUpdating = True 

末次

作为一种解决方法，因为只有最近的数据立即中肯，我工作围绕它，但删除前150页。仍然留下了大约100张用于我的宏的工作，但现在缺失的数据似乎在那里。我想知道是否有关于造成这种故障的纸张数量的问题？

Answer 1

评论可能无法正确显示。重构你的循环（并添加提到的变量）。

Dim x as Long 
Dim thisSht as Worksheet 

For x = 1 to wrk.Worksheets.Count 
    set thisSht = wrk.Worksheets(x) 
    'Data range in worksheet - starts from second row as first rows are the header rows in all worksheets 
    Set rng = thisSht.Range(sht.Cells(2, 1), sht.Cells(65536, 1).End(xlUp).Resize(, colCount)) 
    'Put data into the Master worksheet 
    trg.Cells(65536, 1).End(xlUp).Offset(1).Resize(rng.Rows.Count, rng.Columns.Count).Value = rng.Value 
Next x