[發問] 求高手幫忙簡化程式碼 excel, VBA

s13030029

程式內容是將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

複製代碼

test篩選複製.rar (26.52 KB)

附檔
下載次數: 6

2019-5-27 09:45

kim223824

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

    test篩選複製.zip (27.27 KB)

下載次數: 3

2019-5-30 17:44

GBKEE

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

複製代碼