返回列表 上一主題 發帖

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

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

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

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

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

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

單價分析分表:


單價分析總表執行結果:



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
用行動裝置瀏覽論壇學習很方便,謝謝論壇經營團隊
請大家一起上論壇來交流

TOP

回復 12# 准提部林

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

TOP

以下是試著練習的結果 程式很攏長 請大大們指點一下看看有沒有地方不適合這樣的寫法
請告知小弟  請問如果要設定列印分頁的頁數範圍 該如何寫呢? 請大大們幫幫忙
  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
複製代碼

TOP

用字典帶入編號:
Xl0000176-1.rar (23.13 KB)

TOP

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

回復 9# edmondsforum

編號限定 1 ~ 99
更正檔:
Xl0000176.rar (23.88 KB)

TOP

回復 8# jcchiang


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

TOP

回復 7# 准提部林

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

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

TOP

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

TOP

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

回復 5# edmondsforum


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

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

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

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


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

TOP

        靜思自在 : 虛空有盡.我願無窮,發願容易行願難。
返回列表 上一主題