将前两列从所有工作表复制到主工作表的宏正在跳过工作表

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

在网上搜索解决方案时，我遇到了这个宏，它似乎做同样的事情，但似乎也跳过了与我的宏完全相同的工作表。

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