如何解决压缩vba中的每个循环
我正在将基于一个值的数据从一个打开的工作簿复制到另一个。我在目标工作簿工作表中有一个值列表,并且有一个循环可在另一个开放源工作簿工作表中查找这些值。该代码工作正常,但是,通过我进行设置的方式,我没有更多空间为目标工作簿添加特殊粘贴或数字格式功能。我知道必须有一种简单的方法来压缩我的代码,只是很难弄清楚。
Sub Conditionalcopy()
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步) for each
循环太多
您应该尽量少用。并根据需要添加其中的If
个。您可以用Select Case statement
If
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
您是数据的所有者,因此您必须使用上述提示来改进上述代码,以满足您的需求。
祝你好运!
版权声明:本文内容由互联网用户自发贡献,该文观点与技术仅代表作者本人。本站仅提供信息存储空间服务,不拥有所有权,不承担相关法律责任。如发现本站有涉嫌侵权/违法违规的内容, 请发送邮件至 dio@foxmail.com 举报,一经查实,本站将立刻删除。