試試看是否符合
Sub ex()
Dim sht As Object
Dim r%
r = 6
Sheets("單價分析總表").Cells.Clear
For Each sht In Worksheets
If sht.Name Like "*單價分析" Then
With Sheets(sht.Name)
.Range(.[b2], .Cells(.[c65535].End(3).Row, 8)).Copy Sheets("單價分析總表").Cells(r, 2)
r = r + .[c65535].End(3).Row
End With
End If
Next
With Sheets("單價分析總表")
.Cells.Font.Name = "華康隸書體W5"
.[b5].Value = "項次"
.[b5].HorizontalAlignment = xlCenter
With .Range("B2:H2")
.Merge
.Value = "感謝麻辣家族討論版"
.HorizontalAlignment = xlCenter
.Font.Bold = True
.Font.Size = 16
End With
With .Range("B3:H3")
.Merge
.Value = "單價分析表"
.HorizontalAlignment = xlCenter
.Font.Underline = xlUnderlineStyleSingle
.Font.Size = 14
End With
.Range("c4:H4").Merge
.[c4].Value = "工程名稱：麻辣家族討論版"
.Range("c5:H5").Merge
.[c5].Value = "工程編號：Excelvba"
.Range(.[b6], .Cells(.[c65535].End(3).Row, 8)) = .Range(.[b6], .Cells(.[c65535].End(3).Row, 8)).Value
.Columns("A:I").AutoFit
End With
End Sub作者: 准提部林 時間: 2020-7-23 13:00
Sub TEST()
Dim xR As Range, xS As Worksheet, xU As Range
With Sheets("單價分析總表")
.UsedRange.Offset(5, 0).EntireRow.Delete
Set xR = .[B6]
End With
For Each xS In Sheets
If Right(xS.Name, 4) <> "單價分析" Then GoTo 101
Set xU = Intersect(xS.[B:H], xS.UsedRange).Offset(1, 0)
With xR.Resize(xU.Rows.Count, xU.Columns.Count)
xU.Copy .Cells
.Value = .Value
End With
Set xR = xR(xU.Rows.Count + 1)
101: Next
Range(xR(-xR.Row + 3, 1), xR(-1, 7)).Name = "Print_Area"
End Sub
Sub ex1()
Dim arr, a, c, B%, QQ%, R%
Dim sht As Object
Dim d As Object
Set d = CreateObject("Scripting.Dictionary")
Sheets("單價分析總表").Cells.Clear
arr = Array("一", "二", "三", "四", "五") '工程項次
For Each sht In Worksheets
If sht.Name Like "*單價分析" Then
With Sheets(sht.Name)
For Each a In .Range(.[b2], .[b65535].End(3))
For x = 0 To UBound(arr)
If a.Value = arr(x) And Not d.Exists(a.Value) Then d.Add a.Value, sht.Name & "@" & a.Address
Next
Next
End With
End If
Next
R = 6
For Each a In arr
For B = 0 To d.Count - 1
If a = d.keys()(B) Then
c = Split(d.items()(B), "@")
With Sheets(c(0))
For QQ = 1 To 100
If .Range(c(1)).Offset(QQ, 1) = "小 計" Then Exit For
Next
.Range(c(1)).Resize(QQ + 2, 8).Copy Sheets("單價分析總表").Cells(R, 2)
R = R + QQ + 3
End With
End If
Next
Next
With Sheets("單價分析總表")
.Cells.Font.Name = "華康隸書體W5"
.Cells.Font.ColorIndex = 1
.[b5].Value = "項次"
.[b5].HorizontalAlignment = xlCenter
With .Range("B2:H2")
.Merge
.Value = "感謝麻辣家族討論版"
.HorizontalAlignment = xlCenter
.Font.Bold = True
.Font.Size = 16
End With
With .Range("B3:H3")
.Merge
.Value = "單價分析表"
.HorizontalAlignment = xlCenter
.Font.Underline = xlUnderlineStyleSingle
.Font.Size = 14
End With
.Range("c4:H4").Merge
.[c4].Value = "工程名稱：麻辣家族討論版"
.Range("c5:H5").Merge
.[c5].Value = "工程編號：Excelvba"
.Range(.[b6], .Cells(.[c65535].End(3).Row, 8)) = .Range(.[b6], .Cells(.[c65535].End(3).Row, 8)).Value
End With
Set d = Nothing
End Sub作者: edmondsforum 時間: 2020-8-4 11:14
Option Explicit
Sub TEST()
Dim Z, Q, i&, R&, V&, c%, xR As Range, xA As Range, Sh As Worksheet
Set Z = CreateObject("Scripting.Dictionary")
Set Sh = 工作表1: Range(Sh.[A1], Sh.UsedRange).Offset(5).Delete
Set xR = [單價分析總表!B6]
For i = 0 To 10: Z(Right(Application.Text(i, "[DBNum1]"), 1)) = i: Next
For i = 1 To Worksheets.Count
If Right(Trim(Sheets(i).Name), 5) <> "-單價分析" Then GoTo i01
Q = Trim(Sheets(i).[B2]) & "○○○"
For c = 1 To 3: V = Val(V & Z(Mid(Q, c, 1))): Next
Set Z(V) = Sheets(i): V = 0
i01: Next
For i = 1 To Z.Count
Q = Application.Small(Z.Keys, i)
If IsError(Q) Then Exit For
Set xA = Range(Z(Q).[B2], Z(Q).[G65536].End(3)(1, 2))
xA.Copy xR
Set xR = xR.Item(xA.Rows.Count + 2)
Next
With Sh.UsedRange: .Font.ColorIndex = 1: .Value = .Value: End With
Range(Sh.[A1], xR(-1, 8)).Name = "Print_Area"
End Sub
