- 帖子
- 234
- 主題
- 19
- 精華
- 0
- 積分
- 276
- 點名
- 0
- 作業系統
- Windows XP
- 軟體版本
- office 2003
- 閱讀權限
- 20
- 性別
- 男
- 註冊時間
- 2013-1-7
- 最後登錄
- 2021-10-7
|
本帖最後由 jcchiang 於 2020-7-29 10:51 編輯
回復 4# edmondsforum
准大已經點出很多可能的問題,先以檔案的資料做程式調整,其餘部份請自行修改
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 |
|
發表於 2020-7-23 09:02
| 
