[發問] 如何簡化巨集

luke

各位先進!

我錄製了乙個巨集, 煩請先進簡化.

Sub Macro1()
    Range("A17").Select
    ActiveCell.FormulaR1C1 = _
        "=IF(R[-2]C="""","""",VLOOKUP(R[-2]C,sheet2!R2C1:R[5]C[5],3,0))"
    Range("A18").Select
    ActiveCell.FormulaR1C1 = _
        "=IF(R[-3]C="""","""",VLOOKUP(R[-3]C,sheet2!R2C1:R[4]C[5],4,0))"
    Range("A19").Select
    ActiveCell.FormulaR1C1 = _
        "=IF(R[-4]C="""","""",VLOOKUP(R[-4]C,sheet2!R2C1:R[3]C[5],5,0))"
    Range("A20").Select
    ActiveCell.FormulaR1C1 = _
        "=IF(R[-5]C="""","""",VLOOKUP(R[-5]C,sheet2!R2C1:R[2]C[5],6,0))"
    Range("A17:A20").Select
    Selection.Copy
    Range("a17:K20").Select
    ActiveSheet.Paste
    Range("a24:K27").Select
    ActiveSheet.Paste
    Range("a31:K34").Select
    ActiveSheet.Paste
    Range("a38:K41").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
End Sub

register313

回復 1# luke

請上傳EXCEL壓縮檔,並說明所需之功能要求

luke

回復 2# register313


   這是小弟所錄製的原始檔

  煩請先進指導
[attach]10268[/attach]

register313

回復 3# luke

1. Sub XX()
   
2. Set Rng = Union([A15:K15], [A22:K22], [A29:K29], [A36:K36])
   
3. For Each R In Rng
   
4.     Set s = Sheets("Sheet2").[A:A].Find(R, , , xlWhole)
   
5.     If Not s Is Nothing Then
   
6.        R.Resize(6, 1) = Application.Transpose(s.Resize(1, 6))
   
7.     End If
   
8. Next
   
9. End Sub

複製代碼

Hsieh

回復 3# luke

1. Sub nn()
   
2. Set d = CreateObject("Scripting.Dictionary")
   
3. With sheet2
   
4.    For Each a In .Range(.[A1], .[A1].End(xlDown))
   
5.       d(a.Value) = a.Offset(, 1).Resize(, 5).Value
   
6.    Next
   
7. End With
   
8. With sheet1
   
9. For Each a In .UsedRange.SpecialCells(xlCellTypeConstants, xlNumbers)
   
10.    a.Offset(1).Resize(UBound(d(a.Value), 2), 1) = Application.Transpose(d(a.Value))
    
11. Next
    
12. End With
    
13. End Sub

複製代碼

register313

回復 5# Hsieh

若儲存格為數字但並非字典裡的關鍵字,該如何防錯

1. Sub nn()
   
2. Set d = CreateObject("Scripting.Dictionary")
   
3. With sheet2
   
4.    For Each a In .Range(.[A1], .[A1].End(xlDown))
   
5.       d(a.Value) = a.Offset(, 1).Resize(, 5).Value
   
6.    Next
   
7. End With
   
8. With sheet1
   
9. For Each a In .UsedRange.SpecialCells(xlCellTypeConstants, xlNumbers)
   
10.    If d.Exists(a.Value) Then
    
11.       a.Offset(1).Resize(UBound(d(a.Value), 2), 1) = Application.Transpose(d(a.Value))
    
12.    End If
    
13. Next
    
14. End With
    
15. End Sub

複製代碼

GBKEE

回復 6# register313

1. Sub Ex()
   
2.     Dim A As Range, F As Range
   
3.     For Each A In sheet1.UsedRange.SpecialCells(xlCellTypeConstants, xlNumbers)
   
4.         Set F = sheet2.[A:A].Find(A, lookat:=xlWhole)
   
5.         With A.Offset(1).Resize(5)
   
6.             .Value = ""
   
7.             If Not F Is Nothing Then .Value = Application.Transpose(F.Offset(, 1).Resize(, 5).Value)
   
8.         End With
   
9.     Next
   
10. End Sub
    
11. Sub Ex1()
    
12.     Dim A As Range, F As Variant
    
13.     For Each A In sheet1.UsedRange.SpecialCells(xlCellTypeConstants, xlNumbers)
    
14.          F = Application.Match(A, sheet2.[A:A], 0)
    
15.         With A.Offset(1).Resize(5)
    
16.             .Value = ""
    
17.             If Not IsError(F) Then .Value = Application.Transpose(sheet2.Cells(F, "A").Offset(, 1).Resize(, 5).Value)
    
18.         End With
    
19.     Next
    
20. End Sub

複製代碼

Hsieh

回復 6# register313

With sheet1
For Each a In Union(.[A15:K15], .[A22:K22], .[A29:K29], .[A36:K36]).SpecialCells(xlCellTypeConstants)
   a.Offset(1).Resize(UBound(d(a.Value), 2), 1) = Application.Transpose(d(a.Value))
Next
End With