[發問] 請教，如何複製不同工作表特定欄位(忽略空白值)到一個工作表上

帖子: 234
主題: 19
精華: 0
積分: 276
點名: 0
作業系統: Windows XP
軟體版本: office 2003
閱讀權限: 20
性別: 男
註冊時間: 2013-1-7
最後登錄: 2021-10-7

2^#

發表於 2020-7-23 09:02 | 只看該作者

回復 1# edmondsforum

試試看是否符合
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

版主 Rank: 7 Rank: 7 Rank: 7

准提部林

帖子: 2843
主題: 10
精華: 0
積分: 2899
點名: 0
作業系統: 〔略〕
軟體版本: 〔略〕
閱讀權限: 100
性別: 男
來自: 〔略〕
註冊時間: 2013-5-13
最後登錄: 2025-10-18

3^#

發表於 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

第６行以上自行處理～～
　
　
＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝

帖子: 41
主題: 7
精華: 0
積分: 52
點名: 0
作業系統: Windows10
軟體版本: 2019
閱讀權限: 20
性別: 男
註冊時間: 2017-11-28
最後登錄: 2025-3-4

論壇贊助勳章

4^#

發表於 2020-7-28 09:29 | 只看該作者

回復 2# jcchiang

謝謝J大相當成功!!
這邊有兩個問題想請教：
1.單價分析總表的項次，能依照各地子項單價分析編號一二三四五依照排序複製過來嗎?
我有試著改排水溝-單價分析把它改成五，它還是排第一個。

2.能讓單價分析總表全部都變成黑色嗎? (雖然手動改就好XD) 我發現單位那邊都會變成紅色

帖子: 41
主題: 7
精華: 0
積分: 52
點名: 0
作業系統: Windows10
軟體版本: 2019
閱讀權限: 20
性別: 男
註冊時間: 2017-11-28
最後登錄: 2025-3-4

論壇贊助勳章

5^#

發表於 2020-7-28 09:32 | 只看該作者

回復 3# 准提部林

感謝准大!!!  快狠準耶!!
準大，我這邊的問題也是一樣，

1.單價分析總表的項次，能依照各子項單價分析編號一二三四五依照排序複製過來嗎?
   我有試著改排水溝-單價分析把它改成五，它還是排第一個。

2.能讓單價分析總表全部都變成黑色嗎?  (雖然手動改就好XD) 我發現單位那邊都會變成紅色

帖子: 41
主題: 7
精華: 0
積分: 52
點名: 0
作業系統: Windows10
軟體版本: 2019
閱讀權限: 20
性別: 男
註冊時間: 2017-11-28
最後登錄: 2025-3-4

論壇贊助勳章

6^#

發表於 2020-7-28 09:55 | 只看該作者

不好意思，忘了提及一件事
就是單價分析總表的欄寬能保持不變嗎
因為我原本就設定好了

版主 Rank: 7 Rank: 7 Rank: 7

准提部林

帖子: 2843
主題: 10
精華: 0
積分: 2899
點名: 0
作業系統: 〔略〕
軟體版本: 〔略〕
閱讀權限: 100
性別: 男
來自: 〔略〕
註冊時間: 2013-5-13
最後登錄: 2025-10-18

7^#

發表於 2020-7-28 12:49 | 只看該作者

本帖最後由准提部林於 2020-7-28 12:52 編輯

回復 5# edmondsforum

1.單價分析總表的項次，能依照各子項單價分析編號一二三四五依照排序複製過來嗎?

1) 最多到幾? 10以上,又是怎麼標?
10 = "一十" 或 "十" 或 "一○"
12 = "十二" 或 "一十二"

2) 同一工作表，會不會跳號？或同號
3) 不同工作表, 會不會同號?

中文大寫的數字, 這不太好弄~~最好自行先將工作表順序手動調一調~~或定義工作表名稱順序
至於文字顏色及格式, 應該不難, 可自行去修改或補入程式碼~~樣樣伸手牌不是好習慣

======================================

jcchiang

帖子: 234
主題: 19
精華: 0
積分: 276
點名: 0
作業系統: Windows XP
軟體版本: office 2003
閱讀權限: 20
性別: 男
註冊時間: 2013-1-7
最後登錄: 2021-10-7

8^#

發表於 2020-7-29 10:42 | 只看該作者

本帖最後由 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