2. コンピュータテクノロジー
  3. Excel - VBAでの各ループの圧縮

Excel - VBAでの各ループの圧縮

okwaves2024-01-25  7

開いているワークブックから別のワークブックに値に基づいてデータをコピーする作業をしています。宛先ワークブックシートに値のリストがあり、別のオープンソースワークブックシートで値を検索するループがあります。コードは正常に動作しますが、私の設定方法では、宛先ワークブックに特別な Paste 関数や Numberformat 関数を追加する余地がありません。コードを圧縮する簡単な方法が必要であることはわかっていますが、それを理解するのに苦労しています。

サブ条件コピー()

Dim wbSource As Workbook
Dim wsSource As Worksheet
Dim rSource As Range
Dim wbDest As Workbook
Dim wsDest As Worksheet
Dim rng As Range


Set wbDest = ThisWorkbook
Set wsDest = wbDest.Worksheets("VCP Plan")
Set r1 = wsDest.Range("E3")
Set r2 = wsDest.Range("F3")
Set r3 = wsDest.Range("G3")
Set r4 = wsDest.Range("H3")
Set r5 = wsDest.Range("I3")
Set r6 = wsDest.Range("J3")
Set r7 = wsDest.Range("K3")
Set r8 = wsDest.Range("L3")
Set r9 = wsDest.Range("M3")
Set r10 = wsDest.Range("N3")
Set r11 = wsDest.Range("O3")
Set r12 = wsDest.Range("P3")
Set r13 = wsDest.Range("Q3")
Set r14 = wsDest.Range("B2")
Set r15 = wsDest.Range("C2")
Set r16 = wsDest.Range("D2")
Set r17 = wsDest.Range("E8")
Set r18 = wsDest.Range("F8")
Set r19 = wsDest.Range("G8")
Set r20 = wsDest.Range("H8")
Set r21 = wsDest.Range("I8")
Set r22 = wsDest.Range("J8")
Set r23 = wsDest.Range("K8")
Set r24 = wsDest.Range("L8")
Set r25 = wsDest.Range("M8")
Set r26 = wsDest.Range("N8")
Set r27 = wsDest.Range("O8")
Set r28 = wsDest.Range("P8")
Set r29 = wsDest.Range("Q8")
Set r30 = wsDest.Range("B7")
Set r31 = wsDest.Range("C7")
Set r32 = wsDest.Range("D7")
Set r33 = wsDest.Range("E13")
Set r34 = wsDest.Range("F13")
Set r35 = wsDest.Range("G13")
Set r36 = wsDest.Range("H13")
Set r37 = wsDest.Range("I13")
Set r38 = wsDest.Range("J13")
Set r39 = wsDest.Range("K13")
Set r40 = wsDest.Range("L13")
Set r41 = wsDest.Range("M13")
Set r42 = wsDest.Range("N13")
Set r43 = wsDest.Range("O13")
Set r44 = wsDest.Range("P13")
Set r45 = wsDest.Range("Q13")
Set r46 = wsDest.Range("B12")
Set r47 = wsDest.Range("C12")
Set r48 = wsDest.Range("D12")
Set r49 = wsDest.Range("E18")
Set r50 = wsDest.Range("F18")
Set r51 = wsDest.Range("G18")
Set r52 = wsDest.Range("H18")
Set r53 = wsDest.Range("I18")
Set r54 = wsDest.Range("J18")
Set r55 = wsDest.Range("K18")
Set r56 = wsDest.Range("L18")
Set r57 = wsDest.Range("M18")
Set r58 = wsDest.Range("N18")
Set r59 = wsDest.Range("O18")
Set r60 = wsDest.Range("P18")
Set r61 = wsDest.Range("Q18")
Set r62 = wsDest.Range("B17")
Set r63 = wsDest.Range("C17")
Set r64 = wsDest.Range("D17")
Set r65 = wsDest.Range("E23")
Set r66 = wsDest.Range("F23")
Set r67 = wsDest.Range("G23")
Set r68 = wsDest.Range("H23")
Set r69 = wsDest.Range("I23")
Set r70 = wsDest.Range("J23")
Set r71 = wsDest.Range("K23")
Set r72 = wsDest.Range("L23")
Set r73 = wsDest.Range("M23")
Set r74 = wsDest.Range("N23")
Set r75 = wsDest.Range("O23")
Set r76 = wsDest.Range("P23")
Set r77 = wsDest.Range("Q23")
Set r78 = wsDest.Range("B22")
Set r79 = wsDest.Range("C22")
Set r80 = wsDest.Range("D22")
Set r81 = wsDest.Range("E28")
Set r82 = wsDest.Range("F28")
Set r83 = wsDest.Range("G28")
Set r84 = wsDest.Range("H28")
Set r85 = wsDest.Range("I28")
Set r86 = wsDest.Range("J28")
Set r87 = wsDest.Range("K28")
Set r88 = wsDest.Range("L28")
Set r89 = wsDest.Range("M28")
Set r90 = wsDest.Range("N28")
Set r91 = wsDest.Range("O28")
Set r92 = wsDest.Range("P28")
Set r93 = wsDest.Range("Q28")
Set r94 = wsDest.Range("B27")
Set r95 = wsDest.Range("C27")
Set r96 = wsDest.Range("D27")
Set r97 = wsDest.Range("E33")
Set r98 = wsDest.Range("F33")
Set r99 = wsDest.Range("G33")
Set r100 = wsDest.Range("H33")
Set r101 = wsDest.Range("I33")
Set r102 = wsDest.Range("J33")
Set r103 = wsDest.Range("K33")
Set r104 = wsDest.Range("L33")
Set r105 = wsDest.Range("M33")
Set r106 = wsDest.Range("N33")
Set r107 = wsDest.Range("O33")
Set r108 = wsDest.Range("P33")
Set r109 = wsDest.Range("Q33")
Set r110 = wsDest.Range("B32")
Set r111 = wsDest.Range("C32")
Set r112 = wsDest.Range("D32")
Set r113 = wsDest.Range("E38")
Set r114 = wsDest.Range("F38")
Set r115 = wsDest.Range("G38")
Set r116 = wsDest.Range("H38")
Set r117 = wsDest.Range("I38")
Set r118 = wsDest.Range("J38")
Set r119 = wsDest.Range("K38")
Set r120 = wsDest.Range("L38")
Set r121 = wsDest.Range("M38")
Set r122 = wsDest.Range("N38")
Set r123 = wsDest.Range("O38")
Set r124 = wsDest.Range("P38")
Set r125 = wsDest.Range("Q38")
Set r126 = wsDest.Range("B37")
Set r127 = wsDest.Range("C37")
Set r128 = wsDest.Range("D37")
Set r129 = wsDest.Range("E43")
Set r130 = wsDest.Range("F43")
Set r131 = wsDest.Range("G43")
Set r132 = wsDest.Range("H43")
Set r133 = wsDest.Range("I43")
Set r134 = wsDest.Range("J43")
Set r135 = wsDest.Range("K43")
Set r136 = wsDest.Range("L43")
Set r137 = wsDest.Range("M43")
Set r138 = wsDest.Range("N43")
Set r139 = wsDest.Range("O43")
Set r140 = wsDest.Range("P43")
Set r141 = wsDest.Range("Q43")
Set r142 = wsDest.Range("B42")
Set r143 = wsDest.Range("C42")
Set r144 = wsDest.Range("D42")
Set r145 = wsDest.Range("E48")
Set r146 = wsDest.Range("F48")
Set r147 = wsDest.Range("G48")
Set r148 = wsDest.Range("H48")
Set r149 = wsDest.Range("I48")
Set r150 = wsDest.Range("J48")
Set r151 = wsDest.Range("K48")
Set r152 = wsDest.Range("L48")
Set r153 = wsDest.Range("M48")
Set r154 = wsDest.Range("N48")
Set r155 = wsDest.Range("O48")
Set r156 = wsDest.Range("P48")
Set r157 = wsDest.Range("Q48")
Set r158 = wsDest.Range("B47")
Set r159 = wsDest.Range("C47")
Set r160 = wsDest.Range("D47")
Set r161 = wsDest.Range("E53")
Set r162 = wsDest.Range("F53")
Set r163 = wsDest.Range("G53")
Set r164 = wsDest.Range("H53")
Set r165 = wsDest.Range("I53")
Set r166 = wsDest.Range("J53")
Set r167 = wsDest.Range("K53")
Set r168 = wsDest.Range("L53")
Set r169 = wsDest.Range("M53")
Set r170 = wsDest.Range("N53")
Set r171 = wsDest.Range("O53")
Set r172 = wsDest.Range("P53")
Set r173 = wsDest.Range("Q53")
Set r174 = wsDest.Range("B52")
Set r175 = wsDest.Range("C52")
Set r176 = wsDest.Range("D52")
Set r177 = wsDest.Range("E58")
Set r178 = wsDest.Range("F58")
Set r179 = wsDest.Range("G58")
Set r180 = wsDest.Range("H58")
Set r181 = wsDest.Range("I58")
Set r182 = wsDest.Range("J58")
Set r183 = wsDest.Range("K58")
Set r184 = wsDest.Range("L58")
Set r185 = wsDest.Range("M58")
Set r186 = wsDest.Range("N58")
Set r187 = wsDest.Range("O58")
Set r188 = wsDest.Range("P58")
Set r189 = wsDest.Range("Q58")
Set r190 = wsDest.Range("B57")
Set r191 = wsDest.Range("C57")
Set r192 = wsDest.Range("D57")
Set r193 = wsDest.Range("E63")
Set r194 = wsDest.Range("F63")
Set r195 = wsDest.Range("G63")
Set r196 = wsDest.Range("H63")
Set r197 = wsDest.Range("I63")
Set r198 = wsDest.Range("J63")
Set r199 = wsDest.Range("K63")
Set r200 = wsDest.Range("L63")
Set r201 = wsDest.Range("M63")
Set r202 = wsDest.Range("N63")
Set r203 = wsDest.Range("O63")
Set r204 = wsDest.Range("P63")
Set r205 = wsDest.Range("Q63")
Set r206 = wsDest.Range("B62")
Set r207 = wsDest.Range("C62")
Set r208 = wsDest.Range("D62")
Set r209 = wsDest.Range("E68")
Set r210 = wsDest.Range("F68")
Set r211 = wsDest.Range("G68")
Set r212 = wsDest.Range("H68")
Set r213 = wsDest.Range("I68")
Set r214 = wsDest.Range("J68")
Set r215 = wsDest.Range("K68")
Set r216 = wsDest.Range("L68")
Set r217 = wsDest.Range("M68")
Set r218 = wsDest.Range("N68")
Set r219 = wsDest.Range("O68")
Set r220 = wsDest.Range("P68")
Set r221 = wsDest.Range("Q68")
Set r222 = wsDest.Range("B67")
Set r223 = wsDest.Range("C67")
Set r224 = wsDest.Range("D67")
Set r225 = wsDest.Range("E73")
Set r226 = wsDest.Range("F73")
Set r227 = wsDest.Range("G73")
Set r228 = wsDest.Range("H73")
Set r229 = wsDest.Range("I73")
Set r230 = wsDest.Range("J73")
Set r231 = wsDest.Range("K73")
Set r232 = wsDest.Range("L73")
Set r233 = wsDest.Range("M73")
Set r234 = wsDest.Range("N73")
Set r235 = wsDest.Range("O73")
Set r236 = wsDest.Range("P73")
Set r237 = wsDest.Range("Q73")
Set r238 = wsDest.Range("B72")
Set r239 = wsDest.Range("C72")
Set r240 = wsDest.Range("D72")
Set r241 = wsDest.Range("E78")
Set r242 = wsDest.Range("F78")
Set r243 = wsDest.Range("G78")
Set r244 = wsDest.Range("H78")
Set r245 = wsDest.Range("I78")
Set r246 = wsDest.Range("J78")
Set r247 = wsDest.Range("K78")
Set r248 = wsDest.Range("L78")
Set r249 = wsDest.Range("M78")
Set r250 = wsDest.Range("N78")
Set r251 = wsDest.Range("O78")
Set r252 = wsDest.Range("P78")
Set r253 = wsDest.Range("Q78")
Set r254 = wsDest.Range("B77")
Set r255 = wsDest.Range("C77")
Set r256 = wsDest.Range("D77")
Set r257 = wsDest.Range("E83")
Set r258 = wsDest.Range("F83")
Set r259 = wsDest.Range("G83")
Set r260 = wsDest.Range("H83")
Set r261 = wsDest.Range("I83")
Set r262 = wsDest.Range("J83")
Set r263 = wsDest.Range("K83")
Set r264 = wsDest.Range("L83")
Set r265 = wsDest.Range("M83")
Set r266 = wsDest.Range("N83")
Set r267 = wsDest.Range("O83")
Set r268 = wsDest.Range("P83")
Set r269 = wsDest.Range("Q83")
Set r270 = wsDest.Range("B82")
Set r271 = wsDest.Range("C82")
Set r272 = wsDest.Range("D82")


Dim OpenWorkBook As Variant
OpenWorkBook = Application.GetOpenFilename("Excel Files (*.xlsx* (*.xlsx*),")

If OpenWorkBook <> False Then
    Set wbSource = Workbooks.Open(OpenWorkBook)
Else
    Exit Sub
End If

Set wsSource = wbSource.Worksheets("Sheet0")
Application.ScreenUpdating = False

Dim Cell As Range
With wsSource
    Set rSource = .Range(.Cells(1, 4), .Cells(.Rows.Count, 4).End(xlUp))
End With

For Each Cell In rSource
    If Cell.Value = "17ARH99092A901" Then
        Cell.Offset(0, 3).Copy Destination:=r1
        Cell.Offset(0, 4).Copy Destination:=r2
        Cell.Offset(0, 5).Copy Destination:=r3
        Cell.Offset(0, 6).Copy Destination:=r4
        Cell.Offset(0, 7).Copy Destination:=r5
        Cell.Offset(0, 8).Copy Destination:=r6
        Cell.Offset(0, 9).Copy Destination:=r7
        Cell.Offset(0, 10).Copy Destination:=r8
        Cell.Offset(0, 11).Copy Destination:=r9
        Cell.Offset(0, 12).Copy Destination:=r10
        Cell.Offset(0, 13).Copy Destination:=r11
        Cell.Offset(0, 14).Copy Destination:=r12
        Cell.Offset(0, 15).Copy Destination:=r13
        Cell.Offset(4, 3).Copy
        r14.PasteSpecial Paste:=xlPasteValues
        Cell.Offset(6, 3).Copy
        r15.PasteSpecial Paste:=xlPasteValues
        Cell.Offset(5, 3).Copy
        r16.PasteSpecial Paste:=xlPasteValues
    End If
Next Cell
For Each Cell In rSource
    If Cell.Value = "17ARH99092A902" Then
        Cell.Offset(0, 3).Copy Destination:=r17
        Cell.Offset(0, 4).Copy Destination:=r18
        Cell.Offset(0, 5).Copy Destination:=r19
        Cell.Offset(0, 6).Copy Destination:=r20
        Cell.Offset(0, 7).Copy Destination:=r21
        Cell.Offset(0, 8).Copy Destination:=r22
        Cell.Offset(0, 9).Copy Destination:=r23
        Cell.Offset(0, 10).Copy Destination:=r24
        Cell.Offset(0, 11).Copy Destination:=r25
        Cell.Offset(0, 12).Copy Destination:=r26
        Cell.Offset(0, 13).Copy Destination:=r27
        Cell.Offset(0, 14).Copy Destination:=r28
        Cell.Offset(0, 15).Copy Destination:=r29
        Cell.Offset(4, 3).Copy
        r30.PasteSpecial Paste:=xlPasteValues
        Cell.Offset(6, 3).Copy
        r31.PasteSpecial Paste:=xlPasteValues
        Cell.Offset(5, 3).Copy
        r32.PasteSpecial Paste:=xlPasteValues
    End If
Next Cell
 For Each Cell In rSource
    If Cell.Value = "17ARH99092A904" Then
        Cell.Offset(0, 3).Copy Destination:=r33
        Cell.Offset(0, 4).Copy Destination:=r34
        Cell.Offset(0, 5).Copy Destination:=r35
        Cell.Offset(0, 6).Copy Destination:=r36
        Cell.Offset(0, 7).Copy Destination:=r37
        Cell.Offset(0, 8).Copy Destination:=r38
        Cell.Offset(0, 9).Copy Destination:=r39
        Cell.Offset(0, 10).Copy Destination:=r40
        Cell.Offset(0, 11).Copy Destination:=r41
        Cell.Offset(0, 12).Copy Destination:=r42
        Cell.Offset(0, 13).Copy Destination:=r43
        Cell.Offset(0, 14).Copy Destination:=r44
        Cell.Offset(0, 15).Copy Destination:=r45
        Cell.Offset(4, 3).Copy
        r46.PasteSpecial Paste:=xlPasteValues
        Cell.Offset(6, 3).Copy
        r47.PasteSpecial Paste:=xlPasteValues
        Cell.Offset(5, 3).Copy
        r48.PasteSpecial Paste:=xlPasteValues
    End If
Next Cell
  For Each Cell In rSource
    If Cell.Value = "17ARH99097A902" Then
        Cell.Offset(0, 3).Copy Destination:=r49
        Cell.Offset(0, 4).Copy Destination:=r50
        Cell.Offset(0, 5).Copy Destination:=r51
        Cell.Offset(0, 6).Copy Destination:=r52
        Cell.Offset(0, 7).Copy Destination:=r53
        Cell.Offset(0, 8).Copy Destination:=r54
        Cell.Offset(0, 9).Copy Destination:=r55
        Cell.Offset(0, 10).Copy Destination:=r56
        Cell.Offset(0, 11).Copy Destination:=r57
        Cell.Offset(0, 12).Copy Destination:=r58
        Cell.Offset(0, 13).Copy Destination:=r59
        Cell.Offset(0, 14).Copy Destination:=r60
        Cell.Offset(0, 15).Copy Destination:=r61
        Cell.Offset(4, 3).Copy
        r62.PasteSpecial Paste:=xlPasteValues
        Cell.Offset(6, 3).Copy
        r63.PasteSpecial Paste:=xlPasteValues
        Cell.Offset(5, 3).Copy
        r64.PasteSpecial Paste:=xlPasteValues
    End If
Next Cell
   For Each Cell In rSource
    If Cell.Value = "17ASA00160D901" Then
        Cell.Offset(0, 3).Copy Destination:=r65
        Cell.Offset(0, 4).Copy Destination:=r66
        Cell.Offset(0, 5).Copy Destination:=r67
        Cell.Offset(0, 6).Copy Destination:=r68
        Cell.Offset(0, 7).Copy Destination:=r69
        Cell.Offset(0, 8).Copy Destination:=r70
        Cell.Offset(0, 9).Copy Destination:=r71
        Cell.Offset(0, 10).Copy Destination:=r72
        Cell.Offset(0, 11).Copy Destination:=r73
        Cell.Offset(0, 12).Copy Destination:=r74
        Cell.Offset(0, 13).Copy Destination:=r75
        Cell.Offset(0, 14).Copy Destination:=r76
        Cell.Offset(0, 15).Copy Destination:=r77
        Cell.Offset(4, 3).Copy
        r78.PasteSpecial Paste:=xlPasteValues
        Cell.Offset(6, 3).Copy
        r79.PasteSpecial Paste:=xlPasteValues
        Cell.Offset(5, 3).Copy
        r80.PasteSpecial Paste:=xlPasteValues
    End If
Next Cell
    For Each Cell In rSource
    If Cell.Value = "17ASA00160D902" Then
        Cell.Offset(0, 3).Copy Destination:=r81
        Cell.Offset(0, 4).Copy Destination:=r82
        Cell.Offset(0, 5).Copy Destination:=r83
        Cell.Offset(0, 6).Copy Destination:=r84
        Cell.Offset(0, 7).Copy Destination:=r85
        Cell.Offset(0, 8).Copy Destination:=r86
        Cell.Offset(0, 9).Copy Destination:=r87
        Cell.Offset(0, 10).Copy Destination:=r88
        Cell.Offset(0, 11).Copy Destination:=r89
        Cell.Offset(0, 12).Copy Destination:=r90
        Cell.Offset(0, 13).Copy Destination:=r91
        Cell.Offset(0, 14).Copy Destination:=r92
        Cell.Offset(0, 15).Copy Destination:=r93
        Cell.Offset(4, 3).Copy
        r94.PasteSpecial Paste:=xlPasteValues
        Cell.Offset(6, 3).Copy
        r95.PasteSpecial Paste:=xlPasteValues
        Cell.Offset(5, 3).Copy
        r96.PasteSpecial Paste:=xlPasteValues
    End If
Next Cell
For Each Cell In rSource
    If Cell.Value = "17ASA00161D902" Then
        Cell.Offset(0, 3).Copy Destination:=r97
        Cell.Offset(0, 4).Copy Destination:=r98
        Cell.Offset(0, 5).Copy Destination:=r99
        Cell.Offset(0, 6).Copy Destination:=r100
        Cell.Offset(0, 7).Copy Destination:=r101
        Cell.Offset(0, 8).Copy Destination:=r102
        Cell.Offset(0, 9).Copy Destination:=r103
        Cell.Offset(0, 10).Copy Destination:=r104
        Cell.Offset(0, 11).Copy Destination:=r105
        Cell.Offset(0, 12).Copy Destination:=r106
        Cell.Offset(0, 13).Copy Destination:=r107
        Cell.Offset(0, 14).Copy Destination:=r108
        Cell.Offset(0, 15).Copy Destination:=r109
        Cell.Offset(4, 3).Copy
        r110.PasteSpecial Paste:=xlPasteValues
        Cell.Offset(6, 3).Copy
        r111.PasteSpecial Paste:=xlPasteValues
        Cell.Offset(5, 3).Copy
        r112.PasteSpecial Paste:=xlPasteValues
    End If
Next Cell
For Each Cell In rSource
    If Cell.Value = "17ASA10119D906" Then
        Cell.Offset(0, 3).Copy Destination:=r113
        Cell.Offset(0, 4).Copy Destination:=r114
        Cell.Offset(0, 5).Copy Destination:=r115
        Cell.Offset(0, 6).Copy Destination:=r116
        Cell.Offset(0, 7).Copy Destination:=r117
        Cell.Offset(0, 8).Copy Destination:=r118
        Cell.Offset(0, 9).Copy Destination:=r119
        Cell.Offset(0, 10).Copy Destination:=r120
        Cell.Offset(0, 11).Copy Destination:=r121
        Cell.Offset(0, 12).Copy Destination:=r122
        Cell.Offset(0, 13).Copy Destination:=r123
        Cell.Offset(0, 14).Copy Destination:=r124
        Cell.Offset(0, 15).Copy Destination:=r125
        Cell.Offset(4, 3).Copy
        r126.PasteSpecial Paste:=xlPasteValues
        Cell.Offset(6, 3).Copy
        r127.PasteSpecial Paste:=xlPasteValues
        Cell.Offset(5, 3).Copy
        r128.PasteSpecial Paste:=xlPasteValues
    End If
Next Cell
For Each Cell In rSource
    If Cell.Value = "17ASA10119D909" Then
        Cell.Offset(0, 3).Copy Destination:=r129
        Cell.Offset(0, 4).Copy Destination:=r130
        Cell.Offset(0, 5).Copy Destination:=r131
        Cell.Offset(0, 6).Copy Destination:=r132
        Cell.Offset(0, 7).Copy Destination:=r133
        Cell.Offset(0, 8).Copy Destination:=r134
        Cell.Offset(0, 9).Copy Destination:=r135
        Cell.Offset(0, 10).Copy Destination:=r136
        Cell.Offset(0, 11).Copy Destination:=r137
        Cell.Offset(0, 12).Copy Destination:=r138
        Cell.Offset(0, 13).Copy Destination:=r139
        Cell.Offset(0, 14).Copy Destination:=r140
        Cell.Offset(0, 15).Copy Destination:=r141
        Cell.Offset(4, 3).Copy
        r142.PasteSpecial Paste:=xlPasteValues
        Cell.Offset(6, 3).Copy
        r143.PasteSpecial Paste:=xlPasteValues
        Cell.Offset(5, 3).Copy
        r144.PasteSpecial Paste:=xlPasteValues
    End If
Next Cell
For Each Cell In rSource
    If Cell.Value = "17ASA10119D912" Then
        Cell.Offset(0, 3).Copy Destination:=r145
        Cell.Offset(0, 4).Copy Destination:=r146
        Cell.Offset(0, 5).Copy Destination:=r147
        Cell.Offset(0, 6).Copy Destination:=r148
        Cell.Offset(0, 7).Copy Destination:=r149
        Cell.Offset(0, 8).Copy Destination:=r150
        Cell.Offset(0, 9).Copy Destination:=r151
        Cell.Offset(0, 10).Copy Destination:=r152
        Cell.Offset(0, 11).Copy Destination:=r153
        Cell.Offset(0, 12).Copy Destination:=r154
        Cell.Offset(0, 13).Copy Destination:=r155
        Cell.Offset(0, 14).Copy Destination:=r156
        Cell.Offset(0, 15).Copy Destination:=r157
        Cell.Offset(4, 3).Copy
        r158.PasteSpecial Paste:=xlPasteValues
        Cell.Offset(6, 3).Copy
        r159.PasteSpecial Paste:=xlPasteValues
        Cell.Offset(5, 3).Copy
        r160.PasteSpecial Paste:=xlPasteValues
    End If
Next Cell
For Each Cell In rSource
    If Cell.Value = "17ASA10133D910" Then
        Cell.Offset(0, 3).Copy Destination:=r161
        Cell.Offset(0, 4).Copy Destination:=r162
        Cell.Offset(0, 5).Copy Destination:=r163
        Cell.Offset(0, 6).Copy Destination:=r164
        Cell.Offset(0, 7).Copy Destination:=r165
        Cell.Offset(0, 8).Copy Destination:=r166
        Cell.Offset(0, 9).Copy Destination:=r167
        Cell.Offset(0, 10).Copy Destination:=r168
        Cell.Offset(0, 11).Copy Destination:=r169
        Cell.Offset(0, 12).Copy Destination:=r170
        Cell.Offset(0, 13).Copy Destination:=r171
        Cell.Offset(0, 14).Copy Destination:=r172
        Cell.Offset(0, 15).Copy Destination:=r173
        Cell.Offset(4, 3).Copy
        r174.PasteSpecial Paste:=xlPasteValues
        Cell.Offset(6, 3).Copy
        r175.PasteSpecial Paste:=xlPasteValues
        Cell.Offset(5, 3).Copy
        r176.PasteSpecial Paste:=xlPasteValues
    End If
Next Cell
For Each Cell In rSource
    If Cell.Value = "17ASA10133D912" Then
        Cell.Offset(0, 3).Copy Destination:=r177
        Cell.Offset(0, 4).Copy Destination:=r178
        Cell.Offset(0, 5).Copy Destination:=r179
        Cell.Offset(0, 6).Copy Destination:=r180
        Cell.Offset(0, 7).Copy Destination:=r181
        Cell.Offset(0, 8).Copy Destination:=r182
        Cell.Offset(0, 9).Copy Destination:=r183
        Cell.Offset(0, 10).Copy Destination:=r184
        Cell.Offset(0, 11).Copy Destination:=r185
        Cell.Offset(0, 12).Copy Destination:=r186
        Cell.Offset(0, 13).Copy Destination:=r187
        Cell.Offset(0, 14).Copy Destination:=r188
        Cell.Offset(0, 15).Copy Destination:=r189
        Cell.Offset(4, 3).Copy
        r190.PasteSpecial Paste:=xlPasteValues
        Cell.Offset(6, 3).Copy
        r191.PasteSpecial Paste:=xlPasteValues
        Cell.Offset(5, 3).Copy
        r192.PasteSpecial Paste:=xlPasteValues
    End If
Next Cell
For Each Cell In rSource
    If Cell.Value = "17ASA10143D904" Then
        Cell.Offset(0, 3).Copy Destination:=r193
        Cell.Offset(0, 4).Copy Destination:=r194
        Cell.Offset(0, 5).Copy Destination:=r195
        Cell.Offset(0, 6).Copy Destination:=r196
        Cell.Offset(0, 7).Copy Destination:=r197
        Cell.Offset(0, 8).Copy Destination:=r198
        Cell.Offset(0, 9).Copy Destination:=r199
        Cell.Offset(0, 10).Copy Destination:=r200
        Cell.Offset(0, 11).Copy Destination:=r201
        Cell.Offset(0, 12).Copy Destination:=r202
        Cell.Offset(0, 13).Copy Destination:=r203
        Cell.Offset(0, 14).Copy Destination:=r204
        Cell.Offset(0, 15).Copy Destination:=r205
        Cell.Offset(4, 3).Copy
        r206.PasteSpecial Paste:=xlPasteValues
        Cell.Offset(6, 3).Copy
        r207.PasteSpecial Paste:=xlPasteValues
        Cell.Offset(5, 3).Copy
        r208.PasteSpecial Paste:=xlPasteValues
    End If
Next Cell
 For Each Cell In rSource
    If Cell.Value = "17ASA10179D001" Then
        Cell.Offset(0, 3).Copy Destination:=r209
        Cell.Offset(0, 4).Copy Destination:=r210
        Cell.Offset(0, 5).Copy Destination:=r211
        Cell.Offset(0, 6).Copy Destination:=r212
        Cell.Offset(0, 7).Copy Destination:=r213
        Cell.Offset(0, 8).Copy Destination:=r214
        Cell.Offset(0, 9).Copy Destination:=r215
        Cell.Offset(0, 10).Copy Destination:=r216
        Cell.Offset(0, 11).Copy Destination:=r217
        Cell.Offset(0, 12).Copy Destination:=r218
        Cell.Offset(0, 13).Copy Destination:=r219
        Cell.Offset(0, 14).Copy Destination:=r220
        Cell.Offset(0, 15).Copy Destination:=r221
        Cell.Offset(4, 3).Copy
        r222.PasteSpecial Paste:=xlPasteValues
        Cell.Offset(6, 3).Copy
        r223.PasteSpecial Paste:=xlPasteValues
        Cell.Offset(5, 3).Copy
        r224.PasteSpecial Paste:=xlPasteValues
    End If
Next Cell
For Each Cell In rSource
    If Cell.Value = "17ASA10179D904" Then
        Cell.Offset(0, 3).Copy Destination:=r225
        Cell.Offset(0, 4).Copy Destination:=r226
        Cell.Offset(0, 5).Copy Destination:=r227
        Cell.Offset(0, 6).Copy Destination:=r228
        Cell.Offset(0, 7).Copy Destination:=r229
        Cell.Offset(0, 8).Copy Destination:=r230
        Cell.Offset(0, 9).Copy Destination:=r231
        Cell.Offset(0, 10).Copy Destination:=r232
        Cell.Offset(0, 11).Copy Destination:=r233
        Cell.Offset(0, 12).Copy Destination:=r234
        Cell.Offset(0, 13).Copy Destination:=r235
        Cell.Offset(0, 14).Copy Destination:=r236
        Cell.Offset(0, 15).Copy Destination:=r237
        Cell.Offset(4, 3).Copy
        r238.PasteSpecial Paste:=xlPasteValues
        Cell.Offset(6, 3).Copy
        r239.PasteSpecial Paste:=xlPasteValues
        Cell.Offset(5, 3).Copy
        r240.PasteSpecial Paste:=xlPasteValues
    End If
Next Cell
For Each Cell In rSource
    If Cell.Value = "17ASA10179D909" Then
        Cell.Offset(0, 3).Copy Destination:=r241
        Cell.Offset(0, 4).Copy Destination:=r242
        Cell.Offset(0, 5).Copy Destination:=r243
        Cell.Offset(0, 6).Copy Destination:=r244
        Cell.Offset(0, 7).Copy Destination:=r245
        Cell.Offset(0, 8).Copy Destination:=r246
        Cell.Offset(0, 9).Copy Destination:=r247
        Cell.Offset(0, 10).Copy Destination:=r248
        Cell.Offset(0, 11).Copy Destination:=r249
        Cell.Offset(0, 12).Copy Destination:=r250
        Cell.Offset(0, 13).Copy Destination:=r251
        Cell.Offset(0, 14).Copy Destination:=r252
        Cell.Offset(0, 15).Copy Destination:=r253
        Cell.Offset(4, 3).Copy
        r254.PasteSpecial Paste:=xlPasteValues
        Cell.Offset(6, 3).Copy
        r255.PasteSpecial Paste:=xlPasteValues
        Cell.Offset(5, 3).Copy
        r256.PasteSpecial Paste:=xlPasteValues
    End If
Next Cell
For Each Cell In rSource
    If Cell.Value = "17ASA10179D910" Then
        Cell.Offset(0, 3).Copy Destination:=r257
        Cell.Offset(0, 4).Copy Destination:=r258
        Cell.Offset(0, 5).Copy Destination:=r259
        Cell.Offset(0, 6).Copy Destination:=r260
        Cell.Offset(0, 7).Copy Destination:=r261
        Cell.Offset(0, 8).Copy Destination:=r262
        Cell.Offset(0, 9).Copy Destination:=r263
        Cell.Offset(0, 10).Copy Destination:=r264
        Cell.Offset(0, 11).Copy Destination:=r265
        Cell.Offset(0, 12).Copy Destination:=r266
        Cell.Offset(0, 13).Copy Destination:=r267
        Cell.Offset(0, 14).Copy Destination:=r268
        Cell.Offset(0, 15).Copy Destination:=r269
        Cell.Offset(4, 3).Copy
        r270.PasteSpecial Paste:=xlPasteValues
        Cell.Offset(6, 3).Copy
        r271.PasteSpecial Paste:=xlPasteValues
        Cell.Offset(5, 3).Copy
        r272.PasteSpecial Paste:=xlPasteValues
    End If
Next Cell

        Application.ScreenUpdating = True
        wbSource.Close savechanges:=False

エンドサブ



------------------------

やるべきことがいくつかあります...何をすべきかを段階的に説明しましょう:

ステップ 1) 変数が多すぎます。範囲のタイプ:

Set r1 = wsDest.Range("E3")
Set r2 = wsDest.Range("F3")
...
Set r12 = wsDest.Range("P3")
Set r13 = wsDest.Range("Q3")
...
Set r14 = wsDest.Range("B2")
Set r15 = wsDest.Range("C2")
Set r16 = wsDest.Range("D2")
...

次のものに置き換えることができます:

Set r1 = wsDest.Range("E3:Q3")
...
Set r2 = wsDest.Range("B2:D2")
...
'and so on!

ステップ 2) 各ループの数が多すぎます

使用量はできるだけ少なくする必要があります。そして、その中に必要な数だけ If を入れます。多くの If を Select Case ステートメントに置き換えることができます

For Each Cell In rSource
    Select Case Cell.Value 
       Case "17ARH99092A901" 
            Cell.Offset(0, 3).Resize(RowSize:=r1.Columns.Count).Copy Destination:=r1
       Case "17ARH99092A902"
            Cell.Offset(0, 3).Resize(RowSize:=r2.Columns.Count).Copy Destination:=r2
       'and so on...
    End Select       

Next

あなたはデータの所有者なので、上記のヒントを使用して、ニーズに合わせて上記のコードを改善する必要があります。

頑張ってください!

新着記事:
モック - Python パッチ適用 FTP インポート単純な IF DAX 関数 (PowerBI)複合PowerShellオブジェクトの作成Acrobat Javascript ダイアログがすべてのフィールド値を返さないfirebase クラウド メッセージング - なぜいつも不正なリクエスト fcm が発生するのですか?Google Cloud Platform - IAM ポリシー条件 - その他の例tensorflow - Python - Keras を使用したマスク検出ニューラル ネットワークr - 最後のプロットのみを保存せずに ggsavexaml - WPF テンプレート カスタム コントロールに変える方法を理解するのに助けが必要ですibm クラウド - Python および IBM Watson SDK: ImportError: ibm_watson という名前のモジュールがありませんknex.js - オブジェクトjsを使用してテーブルを1対多に結合する方法css - CSS3 グラデーション使用時の「不明なプロパティ値」エラー
総合生活情報サイト - OKWAVES
総合生活情報サイト - OKWAVES
生活総合情報サイトokwaves（オールアバウト）。その道のプロ（専門家）が、日常生活をより豊かに快適にするノウハウから業界の最新動向、読み物コラムまで、多彩なコンテンツを発信。

カテゴリ一覧