Question

我有一个包含许多工作表的大型工作簿 - 我需要遍历每个工作表并将特定的数据行复制到主工作表。我对此部分的代码工作正常 - 我想要复制到主工作表的数据将始终在第17行中找到。但是，第17行中我要开始复制数据的位置（列）各不相同。我需要在标题行（第15行）中搜索字符串＆＃34; Expenses＆＃34;，并在找到此单元格后向下移动两行到第17行并从该列开始复制该行数据的其余部分字＆＃34;费用＆＃34;找到了。目前，我的代码只是复制整行数据。任何人都可以帮我修改此代码以搜索字符串然后使用该位置来复制数据吗？

Sub MasterSheet()

Dim Sht As Worksheet

Sheets("Master").Select
Rows("2:" & Rows.Count).ClearContents
Application.ScreenUpdating = False
For Each Sht In ActiveWorkbook.Worksheets
    If Sht.Name <> "Master" Then
        Sht.Select
        Range("A:A").Insert
        Range("A17").Formula = "=Mid(Cell(""filename"",B1),Find(""]"",Cell(""filename""))+1,255)"
        Range("A17").Copy
        Range("A17").PasteSpecial Paste:=xlPasteValues
        Range("A17:T17").Copy
        Sheets("Master").Select
        Range("A65536").End(xlUp).Offset(1, 0).Select
        ActiveSheet.Paste
        Sht.Select
        Range("A:A").Delete
    Else
End If

Next Sht
Sheets("Master").Select
Rows("2:" & Rows.Count).ClearFormats
Application.ScreenUpdating = True
End Sub

Answer 1

Sub MasterSheet()

    Dim Sht As Worksheet, f As Range, shtM As Worksheet
    Dim wb As Workbook

    Set wb = ActiveWorkbook
    Set shtM = wb.Sheets("Master")
    shtM.Rows("2:" & Rows.Count).ClearContents

    Application.ScreenUpdating = False
    For Each Sht In ActiveWorkbook.Worksheets

        If Sht.Name <> shtM.Name Then

            'find the header
            Set f = Sht.Rows(15).Find("Expenses", , xlValues, xlWhole)

            'if the header was found...
            If Not f Is Nothing Then

                With shtM.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)

                    .Value = Sht.Name 'sheet name in ColA
                    'copy the values two rows down from f
                    'change the 100 to suit
                    .Offset(0, 1).Resize(1, 100).Value = _
                              f.Offset(2, 0).Resize(1, 100).Value
                End With
            End If

        End If 'checking this sheet

    Next Sht

    shtM.Rows("2:" & Rows.Count).ClearFormats
    shtM.Select

    Application.ScreenUpdating = True
End Sub

搜索字符串并将单元格向下移动两行

1 个答案: