Question

我有一个具有多张工作表的excel工作簿，如果满足条件，我需要将每个工作表的范围复制到一个“主”工作表中（一个在另一个工作表中）。

每张纸都不同，行和单元格的数量可能会有所不同。
在所有表中（主表除外），单元格B1是一个包含“是”或空白的校验单元格。
如果单元格B1 =“ yes”，则宏必须将范围（从第2行到填写的经纬度）迁移到主工作表中。
所选范围必须在主表中一个又一个地复制（以便像列表一样）

我仍然是VBA的初学者，如果有人可以在代码方面对我有所帮助，我将非常感激：）。

我试图使用“ For Each-Next”来构建代码，但也许最好用Loop cicle或其他东西来制作它。

Sub Migrate_Sheets()  
    Dim wksh As Worksheet, DB_range As Range, end_row As Long, con_cell As Variant

    con_cell = Range("B1")
    'end_row = Range("1048576" & Rows.Count).End(xlUp).Rows

    For Each wksh In Worksheets
        If con_cell = "Yes" Then            
            Set DB_range = Range("2" & Rows.Count).End(xlDown).Rows 
            DB_range.Copy

            wksh("Main").Activate
            'row_end = Range("2" & Rows.Count).End(xlUp).Rows

            Range("A1").End(xlDown).Offset(1, 0).Paste   
        End If      
    Next wksh         
End Sub

Answer 1

这里有很多问题-我建议您阅读VBA基础知识-语法，对象，方法等。

我假设您只是在复制B列。

Sub Migrate_Sheets()

Dim wksh As Worksheet, DB_range As Range

For Each wksh In Worksheets
    If wksh.Name <> "Main" Then 'want to exclude this sheet from the check
        If wksh.Range("B1").Value = "Yes" Then 'refer to the worksheet in the loop
            Set DB_range = wksh.Range("B2", wksh.Range("B" & Rows.Count).End(xlUp)) 'you need Set when assigning object variables
            DB_range.Copy Worksheets("Main").Range("A" & Rows.Count).End(xlUp).Offset(1, 0) 'better to work up from the bottom and then go down 1
        End If
    End If
Next wksh

End Sub

Answer 2

查看是否有帮助，尽管您可能需要进行一些小的更改以匹配数据集。

Sub Migrate_Sheets()
    Dim wksh As Worksheet, mainWS As Worksheet
    Dim DB_range As Range, con_cell As String

    Dim lRow As Long, lCol As Long, lRowMain As Long

    Set mainWS = ThisWorkbook.Worksheets("Main")

    For Each wksh In Worksheets
        con_cell = wksh.Range("B1").Value         'You want to use this variable within the loop

        If wksh.Name <> "Main" And con_cell = "Yes" Then
            lRowMain = lastRC(mainWS, "row", 1) + 1     'Add 1 to the last value to get first empty row
            lRow = lastRC(wksh, "row", 1)               'Get the last row at column 1 - adjust to a different column if no values in column 1
            lCol = lastRC(wksh, "col", 2)               'Get the last column at row 2 - adjust to a different row if no values in row 2

            With mainWS
                .Range(.Cells(lRowMain, 1), .Cells(lRowMain + lRow - 1, lCol)).Value = wksh.Range(wksh.Cells(2, 1), wksh.Cells(lRow, lCol)).Value
            End With

        End If
    Next wksh
End Sub

Function lastRC(sht As Worksheet, RC As String, Optional RCpos As Long = 1) As Long

    If RC = "row" Then
      lastRC = sht.Cells(sht.Rows.Count, RCpos).End(xlUp).row

    ElseIf RC = "col" Then
      lastRC = sht.Cells(RCpos, sht.Columns.Count).End(xlToLeft).Column

    Else
        lastRC = 0

    End If
End Function

如果满足条件，如何将范围从多张纸复制到一张纸（一张纸在另一张纸上）？

2 个答案: