Board logo

標題: [發問] 請教,如何複製不同工作表特定欄位(忽略空白值)到一個工作表上 [打印本頁]

作者: edmondsforum    時間: 2020-7-22 10:16     標題: 請教,如何複製不同工作表特定欄位(忽略空白值)到一個工作表上

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

檔案如附件∼
[attach]32314[/attach]

單價分析總表 就是我要的結果 再拜託各位大大指點迷津
作者: jcchiang    時間: 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
作者: 准提部林    時間: 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

第6行以上自行處理∼∼
 
 
================================
作者: edmondsforum    時間: 2020-7-28 09:29

回復 2# jcchiang

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

2.能讓單價分析總表全部都變成黑色嗎?  (雖然手動改就好XD) 我發現 單位 那邊都會變成 紅色
作者: edmondsforum    時間: 2020-7-28 09:32

回復 3# 准提部林


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

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

   2.能讓單價分析總表全部都變成黑色嗎?  (雖然手動改就好XD) 我發現 單位 那邊都會變成 紅色
作者: edmondsforum    時間: 2020-7-28 09:55

不好意思,忘了提及一件事
就是 單價分析總表的 欄寬 能保持不變嗎
因為我原本就設定好了
作者: 准提部林    時間: 2020-7-28 12:49

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

回復 5# edmondsforum


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

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

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

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


======================================
作者: jcchiang    時間: 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
作者: edmondsforum    時間: 2020-8-4 11:14

回復 7# 准提部林

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

不好意思 准大!我會盡量靠自己去找程式碼!! :P
作者: edmondsforum    時間: 2020-8-4 11:25

回復 8# jcchiang


  謝謝大大,中文大寫排序果然很麻煩,
  最後,如果是以純數字排列呢,例如工程項次裡面是 1 2 3 4 5 , 10 21 35 41 之類的話
  這樣可以不用手改了嗎? 再拜託你了
作者: 准提部林    時間: 2020-8-4 13:33

本帖最後由 准提部林 於 2020-8-4 16:44 編輯

回復 9# edmondsforum

編號限定 1 ~ 99
更正檔:
[attach]32369[/attach]
作者: 准提部林    時間: 2020-8-4 16:54

用字典帶入編號:
[attach]32370[/attach]
作者: 軒云熊    時間: 2020-8-5 22:09

以下是試著練習的結果 程式很攏長 請大大們指點一下看看有沒有地方不適合這樣的寫法
請告知小弟  請問如果要設定列印分頁的頁數範圍 該如何寫呢? 請大大們幫幫忙
  1. Sub 測試練習()
  2.     Application.ScreenUpdating = False

  3.     Dim A()
  4.     For I = 2 To Sheets.Count
  5.         ReDim Preserve A(I - 1)
  6.         A(I - 1) = Sheets(I).Cells(2, 2)
  7.     Next I
  8.    
  9.     G = Application.Max(A)

  10.     ActiveWorkbook.Save
  11.     For k = 1 To G
  12.         For I = 2 To Sheets.Count
  13.             Sheets(I).Select
  14.             If Format(Sheets(I).Cells(2, 2), "[DBNum1]0") = Format(k, "[DBNum1]0") Then
  15.                 If Sheets(1).Cells(6, 2) = "" Then
  16.                     Sheets(I).Range(Cells(1, 1).SpecialCells(xlCellTypeConstants), Sheets(I).Cells(1, 1).SpecialCells(xlCellTypeLastCell)).Copy Sheets(1).Cells(6, 2)
  17.                 ElseIf Sheets(1).Cells(6, 2) <> "" Then
  18.                     u = Sheets(1).Cells(1, 1).SpecialCells(xlCellTypeLastCell).Offset(2, 0).Address(0, 0)
  19.                     Sheets(I).Range(Cells(1, 1).SpecialCells(xlCellTypeConstants), Sheets(I).Cells(1, 1).SpecialCells(xlCellTypeLastCell)).Copy Sheets(1).Cells(Mid(u, 2), 2)
  20.                 End If
  21.             End If
  22.         Next I
  23.     Next k
  24.     Sheets(1).Select
  25.     Range(Cells(1, 1), Cells(1, 1).SpecialCells(xlCellTypeLastCell).Offset(0, 1).Address(0, 0)).Name = "Print_Area"
  26.    
  27.     Application.ScreenUpdating = True
  28. End Sub
複製代碼

作者: edmondsforum    時間: 2020-8-7 10:49

回復 12# 准提部林

謝謝准大,小弟佩服得五體投地啊!
報告准大,小弟有發現你格式原本是使用 [DBNum1]0
因為我想要呈現十 十一 十二 所以我改成  [DBNum1][$-ja-JP]G/通用格式
作者: Andy2483    時間: 2023-12-6 10:34

謝謝論壇,謝謝各位前輩
後學藉此帖學習到很多知識,以1#範例的學習方案如下,請各位前輩指教

單價分析分表:
[attach]37109[/attach]

單價分析總表執行結果:
[attach]37110[/attach]


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




歡迎光臨 麻辣家族討論版版 (http://forum.twbts.com/)