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

edmondsforum

各位大神好，小弟今天遇到我有不同的工作表，大概10個(不同個名稱，如 XXXX-單價分析)
他們的格式都一樣，今天想把他們全部彙整到一個工作表，原本使用錄製巨集，
但是我不知道如何加寫 讓它自動判斷 每個表格之間都會隔一列。

檔案如附件～
1090722-TEST.zip (25.41 KB)

下載次數: 20

2020-7-22 10:13

單價分析總表 就是我要的結果 再拜託各位大大指點迷津

jcchiang

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

准提部林

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

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

edmondsforum

回復 2# jcchiang

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

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

edmondsforum

回復 3# 准提部林


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

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

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

edmondsforum

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

准提部林

回復 5# edmondsforum


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

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

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

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


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

jcchiang

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

edmondsforum

回復 7# 准提部林

回覆准大
1. 十以上就是直接變成 十一 十二、二十一 、三十五之類的。
2.同一個工作表不太可能跳號。
3.不同工作表不會同號。
那如果改成中文數字 1 2 3 4 5 6... 10 11 21 31 是否可行呢

不好意思 准大！我會盡量靠自己去找程式碼!! :P

edmondsforum

回復 8# jcchiang


  謝謝大大，中文大寫排序果然很麻煩，
  最後，如果是以純數字排列呢，例如工程項次裡面是 1 2 3 4 5 ， 10 21 35 41 之類的話
  這樣可以不用手改了嗎? 再拜託你了