Board logo

標題: [發問] 求高手幫忙簡化程式碼 [打印本頁]
作者: s13030029    時間: 2019-5-27 09:45     標題: 求高手幫忙簡化程式碼

程式內容是將sheet1篩選後的資料複製到sheet2的合併儲存格
目前錄製的方法是複製到sheet2後，再合併儲存格
sheet1的資料是變動的
sheet2的合併儲存格是以5列合併為準
希望能用迴圈或其他方式簡化程式碼
  1. Sub 巨集2()
  2.     Range("E9:G15").Select
  3.     Selection.AutoFilter
  4.     ActiveSheet.Range("$E$9:$G$15").AutoFilter Field:=1, Criteria1:="=目視", _
  5.         Operator:=xlOr, Criteria2:="=游標卡尺"
  6.     Range("A9").Select
  7.     Selection.Copy
  8.     Sheets("工作表3").Select
  9.     Range("A13").Select
  10.     Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
  11.         :=False, Transpose:=False
  12.     Sheets("工作表1").Select
  13.     Range("A11").Select
  14.     Application.CutCopyMode = False
  15.     Selection.Copy
  16.     Sheets("工作表3").Select
  17.     Range("A18").Select
  18.     Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
  19.         :=False, Transpose:=False
  20.     Sheets("工作表1").Select
  21.     Range("A14").Select
  22.     Application.CutCopyMode = False
  23.     Selection.Copy
  24.     Sheets("工作表3").Select
  25.     Range("A23").Select
  26.     Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
  27.         :=False, Transpose:=False
  28.     Sheets("工作表1").Select
  29.     Range("A15").Select
  30.     Application.CutCopyMode = False
  31.     Selection.Copy
  32.     Sheets("工作表3").Select
  33.     Range("A28").Select
  34.     Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
  35.         :=False, Transpose:=False
  36.     Sheets("工作表1").Select
  37.     Range("B9:D9").Select
  38.     Application.CutCopyMode = False
  39.     Selection.Copy
  40.     Sheets("工作表3").Select
  41.     Range("B13").Select
  42.     Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
  43.         :=False, Transpose:=False
  44.     Sheets("工作表1").Select
  45.     Range("B11:D11").Select
  46.     Application.CutCopyMode = False
  47.     Selection.Copy
  48.     Sheets("工作表3").Select
  49.     Range("B18").Select
  50.     Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
  51.         :=False, Transpose:=False
  52.     Sheets("工作表1").Select
  53.     Range("B14:D14").Select
  54.     Application.CutCopyMode = False
  55.     Selection.Copy
  56.     Sheets("工作表3").Select
  57.     Range("B23").Select
  58.     Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
  59.         :=False, Transpose:=False
  60.     Sheets("工作表1").Select
  61.     Range("B15:D15").Select
  62.     Application.CutCopyMode = False
  63.     Selection.Copy
  64.     Sheets("工作表3").Select
  65.     Range("B28").Select
  66.     ActiveSheet.Paste
  67.     Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
  68.         :=False, Transpose:=False
  69.     Sheets("工作表1").Select
  70.     Range("E9:G9").Select
  71.     Application.CutCopyMode = False
  72.     ActiveCell.FormulaR1C1 = "目視"
  73.     Sheets("工作表3").Select
  74.     Range("B13").Select
  75.     ActiveCell.FormulaR1C1 = "SIPCSS002-00目視"
  76.     Range("B14").Select
  77.     Sheets("工作表1").Select
  78.     Range("E11:G11").Select
  79.     ActiveCell.FormulaR1C1 = "游標卡尺"
  80.     Sheets("工作表3").Select
  81.     Range("B18").Select
  82.     ActiveCell.FormulaR1C1 = "φ19.93-20.07 游標卡尺"
  83.     Range("B19").Select
  84.     Sheets("工作表1").Select
  85.     Range("E14:G14").Select
  86.     ActiveCell.FormulaR1C1 = "游標卡尺"
  87.     Sheets("工作表3").Select
  88.     Range("B23").Select
  89.     ActiveCell.FormulaR1C1 = "14.90-15.10 游標卡尺"
  90.     Range("B24").Select
  91.     Sheets("工作表1").Select
  92.     Range("E15:G15").Select
  93.     ActiveCell.FormulaR1C1 = "目視"
  94.     Sheets("工作表3").Select
  95.     Range("B28").Select
  96.     ActiveCell.FormulaR1C1 = "袋裝 目視"
  97.     Range("A13:A17").Select
  98.     With Selection
  99.         .HorizontalAlignment = xlCenter
  100.         .VerticalAlignment = xlCenter
  101.         .WrapText = False
  102.         .Orientation = 0
  103.         .AddIndent = False
  104.         .IndentLevel = 0
  105.         .ShrinkToFit = False
  106.         .ReadingOrder = xlContext
  107.         .MergeCells = False
  108.     End With
  109.     Selection.Merge
  110.     Range("B13:B17").Select
  111.     With Selection
  112.         .HorizontalAlignment = xlCenter
  113.         .VerticalAlignment = xlCenter
  114.         .WrapText = False
  115.         .Orientation = 0
  116.         .AddIndent = False
  117.         .IndentLevel = 0
  118.         .ShrinkToFit = False
  119.         .ReadingOrder = xlContext
  120.         .MergeCells = False
  121.     End With
  122.     Selection.Merge
  123.     With Selection
  124.         .HorizontalAlignment = xlCenter
  125.         .VerticalAlignment = xlCenter
  126.         .WrapText = True
  127.         .Orientation = 0
  128.         .AddIndent = False
  129.         .IndentLevel = 0
  130.         .ShrinkToFit = False
  131.         .ReadingOrder = xlContext
  132.         .MergeCells = True
  133.     End With
  134.     ActiveCell.FormulaR1C1 = "SIPCSS002-00     目視"
  135.     Range("B13:B17").Select
  136.     ActiveCell.FormulaR1C1 = "SIPCSS002-00           目視"
  137.     Range("A18:A22").Select
  138.     With Selection
  139.         .HorizontalAlignment = xlCenter
  140.         .VerticalAlignment = xlCenter
  141.         .WrapText = False
  142.         .Orientation = 0
  143.         .AddIndent = False
  144.         .IndentLevel = 0
  145.         .ShrinkToFit = False
  146.         .ReadingOrder = xlContext
  147.         .MergeCells = False
  148.     End With
  149.     Selection.Merge
  150.     Range("B18:B22").Select
  151.     With Selection
  152.         .HorizontalAlignment = xlCenter
  153.         .VerticalAlignment = xlCenter
  154.         .WrapText = False
  155.         .Orientation = 0
  156.         .AddIndent = False
  157.         .IndentLevel = 0
  158.         .ShrinkToFit = False
  159.         .ReadingOrder = xlContext
  160.         .MergeCells = False
  161.     End With
  162.     Selection.Merge
  163.     With Selection
  164.         .HorizontalAlignment = xlCenter
  165.         .VerticalAlignment = xlCenter
  166.         .WrapText = True
  167.         .Orientation = 0
  168.         .AddIndent = False
  169.         .IndentLevel = 0
  170.         .ShrinkToFit = False
  171.         .ReadingOrder = xlContext
  172.         .MergeCells = True
  173.     End With
  174.     Range("B18:B22").Select
  175.     ActiveCell.FormulaR1C1 = "φ19.93-20.07          游標卡尺"
  176.     Range("A23:A27").Select
  177.     With Selection
  178.         .HorizontalAlignment = xlCenter
  179.         .VerticalAlignment = xlCenter
  180.         .WrapText = False
  181.         .Orientation = 0
  182.         .AddIndent = False
  183.         .IndentLevel = 0
  184.         .ShrinkToFit = False
  185.         .ReadingOrder = xlContext
  186.         .MergeCells = False
  187.     End With
  188.     Selection.Merge
  189.     Range("B23:B27").Select
  190.     With Selection
  191.         .HorizontalAlignment = xlCenter
  192.         .VerticalAlignment = xlCenter
  193.         .WrapText = False
  194.         .Orientation = 0
  195.         .AddIndent = False
  196.         .IndentLevel = 0
  197.         .ShrinkToFit = False
  198.         .ReadingOrder = xlContext
  199.         .MergeCells = False
  200.     End With
  201.     Selection.Merge
  202.     With Selection
  203.         .HorizontalAlignment = xlCenter
  204.         .VerticalAlignment = xlCenter
  205.         .WrapText = True
  206.         .Orientation = 0
  207.         .AddIndent = False
  208.         .IndentLevel = 0
  209.         .ShrinkToFit = False
  210.         .ReadingOrder = xlContext
  211.         .MergeCells = True
  212.     End With
  213.     ActiveCell.FormulaR1C1 = "14.90-15.10          游標卡尺"
  214.     Range("A28:A32").Select
  215.     With Selection
  216.         .HorizontalAlignment = xlCenter
  217.         .VerticalAlignment = xlCenter
  218.         .Orientation = 0
  219.         .AddIndent = False
  220.         .IndentLevel = 0
  221.         .ShrinkToFit = False
  222.         .ReadingOrder = xlContext
  223.         .MergeCells = False
  224.     End With
  225.     Selection.Merge
  226.     Range("B28:B32").Select
  227.     With Selection
  228.         .HorizontalAlignment = xlCenter
  229.         .VerticalAlignment = xlCenter
  230.         .Orientation = 0
  231.         .AddIndent = False
  232.         .IndentLevel = 0
  233.         .ShrinkToFit = False
  234.         .ReadingOrder = xlContext
  235.         .MergeCells = False
  236.     End With
  237.     Selection.Merge
  238.     With Selection
  239.         .HorizontalAlignment = xlCenter
  240.         .VerticalAlignment = xlCenter
  241.         .WrapText = True
  242.         .Orientation = 0
  243.         .AddIndent = False
  244.         .IndentLevel = 0
  245.         .ShrinkToFit = False
  246.         .ReadingOrder = xlContext
  247.         .MergeCells = True
  248.     End With
  249.     ActiveCell.FormulaR1C1 = "袋裝         目視"
  250.     Range("B33").Select
  251.     Sheets("工作表1").Select
  252.     Selection.AutoFilter
  253. End Sub
複製代碼
[attach]30673[/attach]
作者: kim223824    時間: 2019-5-30 17:45

回復 1# s13030029

Sub test_20190530()
    ROW1 = Cells(Rows.Count, "E").End(3).Row
    Range("E9:G" & ROW1).Select
    Selection.AutoFilter
    ActiveSheet.Range("$E$9:$G$" & ROW1).AutoFilter Field:=1, Criteria1:="=目視", _
        Operator:=xlOr, Criteria2:="=游標卡尺"
    Sheets("¤u§@ªí3").Cells.Clear
    Range("A9:G" & ROW1).Select
    Selection.SpecialCells(xlCellTypeVisible).Select
    Selection.Copy
    Sheets("¤u§@ªí3").Select
    Range("A1").Select
    ActiveSheet.Paste
    ROW2 = Cells(Rows.Count, "A").End(3).Row
    Range("H1:H" & ROW2) = "=B1 & "" "" & E1"
    Range("H1:H" & ROW2).Value = Range("H1:H" & ROW2).Value
    Columns("B:G").Delete Shift:=xlToLeft
    For i = ROW2 To 1 Step -1
        Range("A" & i & ":A" & i + 4).Merge
        Range("B" & i & ":B" & i + 4).Merge
        Range("B" & i & ":B" & i + 4).WrapText = True
        Range("B" & i & ":B" & i + 4).HorizontalAlignment = xlCenter
        Rows(i & ":" & i + 3).Insert Shift:=xlDown
    Next
    ROW2 = Cells(Rows.Count, "A").End(3).Row
    Range("A5:B" & ROW2).Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    Range("A5").Select
    Columns("B:B").ColumnWidth = 12
    Sheets(1).Select
    Selection.AutoFilter
    Range("A9").Select
End Sub

    [attach]30730[/attach]
作者: GBKEE    時間: 2019-5-31 10:36

回復 1# s13030029
  1. Option Explicit
  2. Sub Ex()
  3.     Dim Rng(1 To 2) As Range, xRow As Integer, AR, i As Integer, xI As Integer
  4.     With Sheets("工作表1")
  5.         xRow = .[A9].End(xlDown).Row
  6.         With .Range("$E$9:$G" & xRow)
  7.             .AutoFilter
  8.             .AutoFilter Field:=1, Criteria1:="=目視", Operator:=xlOr, Criteria2:="=游標卡尺"
  9.             '***篩選後A欄到G欄的資料區域******
  10.             Set Rng(1) = .Parent.Range("A10:G" & xRow).SpecialCells(xlCellTypeVisible)
  11.             '*********************************
  12.             Set Rng(2) = Sheets("工作表3").[A13]
  13.             For i = 1 To Rng(1).Areas.Count                 '**篩選後資料 不一定是連續的
  14.                 For xI = 1 To Rng(1).Areas(i).Rows.Count    ''**篩選後資料的 Areas 集合，此集合代表多區域選取範圍中的所有範圍。
  15.                     AR = Application.Transpose(Application.Transpose(Rng(1).Areas(i).Rows(xI)))
  16.                     'Rng(1).Areas(i).Rows(xI) 轉換成一維陣列
  17.                     
  18.                     '***處理 篩選後A欄到G欄的資料區域  中有沒有資料的欄位******
  19.                     AR = Join(AR, ",")  '陣列以","連結轉為文字
  20.                     Do While InStr(AR, ",,")
  21.                         AR = Replace(AR, ",,", ",")  ' ** 消除多餘的","  '
  22.                     Loop
  23.                     AR = Split(Mid(AR, 1, Len(AR) - 1), ",")  '文字以","轉為陣列
  24.                     With Rng(2)
  25.                         .Cells(1) = AR(0)
  26.                         .Cells(1, 2) = AR(1) & vbLf & AR(2)
  27.                         EX_格式 .Cells(1).Resize(5)
  28.                         EX_格式 .Cells(1, 2).Resize(5)
  29.                     End With
  30.                     Set Rng(2) = Rng(2).Offset(1)
  31.                 Next
  32.            Next
  33.         End With
  34.     End With
  35. End Sub
  36. Sub EX_格式(ByVal Target As Range)
  37.     With Target
  38.         .HorizontalAlignment = xlCenter
  39.         .VerticalAlignment = xlCenter
  40.         .WrapText = False
  41.         .Orientation = 0
  42.         .AddIndent = False
  43.         .IndentLevel = 0
  44.         .ShrinkToFit = False
  45.         .ReadingOrder = xlContext
  46.         '.MergeCells = True
  47.          .Merge
  48.     End With
  49. End Sub
複製代碼




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