ExcelのVBA固有のコピー/ペーストの文字列を別のワークシートの特定の範囲にある範囲で別のシートにコピー

Question

Excel VBAの初心者です！
特定の文字列が見つかると、ワークシート "ジョブ"からワークシート "Einfügen"に範囲をコピーするタスクがあります。
これまで私が行ってきたことは、手動で選択して「ジョブ」から「Einfügen」にコピー＆ペーストすることです。私はVBAを使用して "ジョブ"（各範囲は1600、列は4または6になることができます行の固定量を持っている）で利用可能な19の範囲のうち6つの範囲を選択してコピーする、私は各テーブルの見出しを検索するつもりですFindメソッドを使用して "Job"シートのColumn Aに移動し、Findの結果とオフセットを動的範囲の開始位置として使用します。

たとえば、文字列 "Av"はA8033にありますが、必要な範囲はC8035から始まります。また、これらの文字列の位置は特定の行に固定されていないため、入力ごとに異なるソートを行うことができます。
したがって、私はこの例ではA8033である "ジョブ"で "Av"ポジションを探しています。これは4行あり、F9635 {F（8035 + 1600）}まで範囲C8035を選択し、 C11：F1611である "Einfügen"の固定範囲です。
さらに6つの見出し文字列すべてを繰り返します。見出しはすべて列Aに表示され、すべての表は検索文字列結果（2,2）と同じオフセット数と同じ数の列（4または6）と同じ行数（1600）を持ちます。 私はそれを解決するために多くの方法を試みたが、残念ながら私はコードを見つけることができませんでした。 私がそれを解決する手助けができたら本当に感謝しています。私の6弦は です：「AV」、」an」は、」AF」、」紫」、」AR」、」LCL」 仕事で私のテーブルのようなある：

 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