Board logo

標題: [發問] 如何簡化巨集 [打印本頁]
作者: luke    時間: 2012-3-31 23:13     標題: 如何簡化巨集

本帖最後由 luke 於 2012-3-31 23:15 編輯

各位先進!

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

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    時間: 2012-4-1 19:25

回復 1# luke

請上傳EXCEL壓縮檔,並說明所需之功能要求
作者: luke    時間: 2012-4-1 22:10

本帖最後由 luke 於 2012-4-1 22:15 編輯

回復 2# register313


   這是小弟所錄製的原始檔

  煩請先進指導
[attach]10268[/attach]
作者: register313    時間: 2012-4-1 23:05

本帖最後由 register313 於 2012-4-1 23:14 編輯

回復 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    時間: 2012-4-1 23:15

回復 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    時間: 2012-4-1 23:30

本帖最後由 register313 於 2012-4-1 23:36 編輯

回復 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    時間: 2012-4-2 07:51

回復 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    時間: 2012-4-2 08:59

回復 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



歡迎光臨 麻辣家族討論版版 (http://forum.twbts.com/)