excel vba-特定的复制/粘贴字符串到另一个工作表，其所有范围都在另一个工作表中的特定范围

Question

我完全是Excel VBA中的新手！
当找到某些字符串时，我有一个任务要复制从工作表“ Job”到工作表“Einfügen”的范围。
我以前所做的是手动选择，然后将其从“作业”复制粘贴到“Einfügen”。 我想使用VBA从“ Job”中的可用19个范围中选择并复制6个范围（每个范围具有固定数量的行，即1600，列可以是4或6），我将搜索每个表标题使用“查找”方法在“作业”表中的A列中输入，然后使用查找结果加上偏移量作为动态范围的起始位置。

因此，例如，在A8033中找到了字符串“ Av”，但是我需要的范围从C8035开始。 这些字符串的位置也没有固定在特定的行中，可以针对不同的输入进行不同的排序。
因此，在这种情况下，我想首先在“作业”中找到“ Av”位置，在本例中为A8033，它有4行，然后选择范围C8035直到F9635 {F（8035 + 1600）}并复制粘贴到“Einfügen”中的固定范围是C11：F1611。
然后重复所有其他6个标题字符串。 标题将全部显示在列A中，所有表与搜索字符串结果的偏移量相同（2,2），列数相同（4或6），行数相同（1600）。 我尝试了很多方法来解决它，但是不幸的是我找不到代码。 如果您能帮助我解决问题，我将不胜感激。 我的6个字符串是：“ Av”，“ An”，“ Af”，“ Zi”，“ Ar”，“ LCL”。在Job中的表如下：

        A    B            C           D           E           F
8033    Av                                  
8034   Idx  [Hz]         DA 1        DA 2        DA 3        DA 4
8035    0   1,00E+06    -9,58E-01   -9,65E-01   -9,74E-01   -9,62E-01
8036    1   2,87E+06    -1,49E+00   -1,51E+00   -1,52E+00   -1,50E+00
8034    2   4,75E+06    -1,84E+00   -1,88E+00   -1,88E+00   -1,86E+00
8035    3   6,62E+06    -2,14E+00   -2,19E+00   -2,17E+00   -2,15E+00
8036    4   8,50E+06    -2,39E+00   -2,45E+00   -2,43E+00   -2,41E+00
8037    5   1,04E+07    -2,63E+00   -2,70E+00   -2,66E+00   -2,65E+00
8038    6   1,22E+07    -2,86E+00   -2,92E+00   -2,89E+00   -2,88E+00
8039    7   1,41E+07    -3,07E+00   -3,14E+00   -3,10E+00   -3,09E+00
.
.
9635   1600 3,00E+09    -6,07E+01   -5,51E+01   -8,11E+01   -4,92E+01

您可以在这里看到我的代码：

Sub DoMyJob()

    Dim IDump As Worksheet
    Dim f As Range
    Dim g As Range
    Dim CapPremRng As Range
    Worksheets("Job").Activate
    Set IDump = Sheets("Job")

    Set f = IDump.Range("A1:A30488").Find(What:="Av", LookIn:=xlValues, LookAt:=xlPart)
    Set g = f.Offset(2, 2).Activate

    Set CapPremRng = g.Range("A1:I" & Lastrow)

    CapPremRng.Copy
    Sheets("Einfügen").Range("C11" & Lastrow).PasteSpecial xlValues

End Sub

Answer 1

尝试以下（注释）代码：

Option Explicit

Sub DoMyJob()
    Dim f As Range
    Dim lastRow As Long
    Dim keyword As Variant

    Const KEYWORDS As String = "Av,An,Af,Zi,Ar,LCL" '<--| list your 'keyword' strings
    Const DATASETROWS As Long = 1600 '<--| define data set range fixed amount of rows
    Const DATASETCOLUMNS As Long = 6 '<--| define data set range maximum amount of columns
    Const COLUMNSOFFSETFROMKEYWORD As Long = 2 '<--| define data set range rows offset from keyword cell
    Const ROWSOFFSETFROMKEYWORD As Long = 2 '<--| define data set columns rows offset from keyword cell

    With Worksheets("Job") '<--| reference your data worksheet
        With .Range("A1", .Cells(.Rows.Count, 1).End(xlUp)) '<--! reference its column "A" cells form row 1 down to last non empty one
            For Each keyword In Split(KEYWORDS, ",") 'loop through 'keywords' list
                Set f = .Find(What:=keyword, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False) '<--| search referenced cells for current 'keyword'
                If Not f Is Nothing Then '<--| if 'keyword' found then...
                    Sheets("Einfügen").Range("C11").Offset(lastRow).Resize(DATASETROWS, DATASETCOLUMNS).Value = _
                    f.Offset(ROWSOFFSETFROMKEYWORD, COLUMNSOFFSETFROMKEYWORD).Resize(DATASETROWS, DATASETCOLUMNS).Value '<--| copy data set fixed range values
                    lastRow = lastRow + DATASETROWS '<--|update destination sheet pasting row
                End If
            Next keyword
        End With
    End With
End Sub