帖子: 59
主題: 31
精華: 0
積分: 120
點名: 0
作業系統: WIn10
軟體版本: OFFICE2013
閱讀權限: 20
註冊時間: 2018-7-19
最後登錄: 2022-4-16

1^# 跳轉到 » 倒序看帖

字體大小: tT

發表於 2022-1-28 11:02 | 只看該作者

[發問] Excel 篩選後複製。

我有一個活頁簿內有多個工作表,我要將相關工作表先做篩選再複製貼上做
樞紐分析表,例如工作表QC3,QC4,QC5 這三個工作表,我是用公式等於 "=" 另外一個工作表的內容,那就是QC3-QC5 由第二列開始,全部為公式= 另外一個活頁簿
內的資料內容,同時因為我是用公式= 另外一張工作表的內容,所以在最後的列是會有0 的問題,0的顯示是該工作表的列沒有資料,因為我不要每次都把公式向下拉再取資料,而是先=該工作表的內容,我要將QC3先篩選K欄 "year" 為2022-1 月份,再由A2:K2 向下複製再貼上至QC Summary 的A2 儲存格,QC4 也是篩選2022-1 , 再由A2:K2 複製至QC Summary,此時複製貼上則是在QC3 剛才複製的資料下方,同時QC5 都是一樣做法,

而CLS-QC5-CLS-QC7 也是一樣做法3個工作表,這次便是A2:K2複製至CLS Summary這樣, 而Total Summary 則我以手動方式,將QC Summary 及CLS-Summary 做樞紐分析表整合資料這樣。

QC3-QC5 這樣只是3個工作表,CLS-QC5-7 也是剛好3個,如果下次有新增的話,都需要根據工作表的多少來自動複製貼上。

最好是自動認別到以QC 開頭的工作表則自動篩選複製貼上至QC Summary 表內,同時CLS-開始的也是自動篩選再複製貼上。
而2022-1 是會根據月份篩選, 到2月時,則要自動篩選2022-2。

所有QC工作表是以公式等於= 另外一張工作表的資料,所以要以實數貼上Summary 。同時每張工作表的內容資料多少都不一樣。

請問如何以VBA 做到以上要求,謝謝

Report.rar (286.46 KB)

樓主熱帖

samwang

高中生 Rank: 3 Rank: 3

帖子: 878
主題: 7
精華: 0
積分: 921
點名: 0
作業系統: Win10
軟體版本: Office 2016
閱讀權限: 50
性別: 男
註冊時間: 2013-4-19
最後登錄: 2022-7-1

2^#

發表於 2022-1-28 13:49 | 只看該作者

回復 1# stephenlee
請測試看看，謝謝
Sub test()
Dim Arr, Brr(1 To 10000, 1 To 11), Crr(1 To 10000, 1 To 11)
Dim T$, T1$, n%, n1%, i%, j%, sh
T = Year(Date) & "-" & Month(Date)
For x = 4 To Sheets.Count
sh = UCase(Left(Sheets(x).Name, 2))
If InStr(sh, "QC") Then
      With Sheets(x)
         Arr = .Range("a1").CurrentRegion
         For i = 2 To UBound(Arr)
            T1 = Arr(i, 11): If Arr(i, 5) = 0 Then Exit For
            If T = T1 Then n = n + 1: For j = 1 To 11: Brr(n, j) = Arr(i, j): Next
         Next
      End With
ElseIf InStr(sh, "CL") Then
      With Sheets(x)
         Arr = .Range("a1").CurrentRegion
         For i = 145 To UBound(Arr)
            T1 = Arr(i, 11): If Arr(i, 5) = 0 Then Exit For
            If T = T1 Then n1 = n1 + 1: For j = 1 To 11: Crr(n1, j) = Arr(i, j): Next
         Next
      End With
End If
Next
If n > 0 Then
With Sheets("QC Summary")
      .Range("a1").CurrentRegion.Offset(1, 0) = ClearContents
      .[a2].Resize(n, 11) = Brr
End With
End If
If n1 > 0 Then
With Sheets("CLS Summary")
      .Range("a1").CurrentRegion.Offset(1, 0) = ClearContents
      .[a2].Resize(n1, 11) = Crr
End With
End If
End Sub

TOP

singo1232001

　暱稱: 熱狗慶

中學生 Rank: 2

帖子: 177
主題: 4
精華: 0
積分: 209
點名: 5
作業系統: windows7
軟體版本: vba,vb,excel2007
閱讀權限: 20
性別: 男
註冊時間: 2017-1-8
最後登錄: 2022-6-8

論壇榮譽勳章論壇贊助勳章

3^#

發表於 2022-1-28 14:01 | 只看該作者

回復 1# stephenlee

Report V1.zip (330.61 KB)

TOP

准提部林

版主 Rank: 7 Rank: 7 Rank: 7

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

4^#

發表於 2022-1-30 08:59 | 只看該作者

Sub TEST_A1()
Dim Arr, Brr(2), N(2), i&, j%, YM$, SS, S As Worksheet, T$, k%
YM = Format(Date, "yyyy-m")
ReDim Arr(1 To 20000, 1 To 11)
Brr(1) = Arr: Brr(2) = Arr
For Each S In Sheets
T = UCase(S.Name)
k = Switch(T Like "QC#*", 1, T Like "CLS-QC#*", 2, T = T, 0)
If k = 0 Then GoTo s99
Arr = S.Range("a1").CurrentRegion
For i = 2 To UBound(Arr)
      If Arr(i, 5) = 0 Then Exit For
      If Arr(i, 11) = YM Then
         N(k) = N(k) + 1
         For j = 1 To UBound(Arr, 2)
            Brr(k)(N(k), j) = Arr(i, j)
         Next j
      End If
Next i
s99: Next
Set SS = Sheets(Array("QC Summary", "CLS Summary"))
For k = 1 To 2
SS(k).UsedRange.Offset(1, 0).EntireRow.Delete
If N(k) > 0 Then SS(k).[a2].Resize(N(k), 11) = Brr(k)
Next k
End Sub

TOP

stephenlee

中學生 Rank: 2

帖子: 59
主題: 31
精華: 0
積分: 120
點名: 0
作業系統: WIn10
軟體版本: OFFICE2013
閱讀權限: 20
註冊時間: 2018-7-19
最後登錄: 2022-4-16

5^#

發表於 2022-2-4 10:30 | 只看該作者

本帖最後由 stephenlee 於 2022-2-4 10:34 編輯

Sub TEST_A1()
Dim Arr, Brr(2), N(2), i&, j%, YM$, SS, S As Worksheet, T$, k%
YM = Format(Date, "yy ...
准提部林發表於 2022-1-30 08:59

感謝淮大,我這些資料來源是用公式= 其他工作表內的資料, 貼上指令碼後,他在13行,以下句子中出現錯誤說

第1至10欄是用公式=其他工作表的資料,而11欄是我用公式將第1欄的日期轉為年份及月份,方便統計整合。

"Type mismatch"
if Arr(i, 11) = YM Then

能不能勞煩幫我看一下,謝謝。

TOP

准提部林

版主 Rank: 7 Rank: 7 Rank: 7

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

6^#

發表於 2022-2-5 16:12 | 只看該作者

回復 5# stephenlee

如果測試檔都沒問題, 是否可能實際資料有公式產生的錯誤值???
自行先找到錯誤所在, 即錯誤在資料, 而不是程式, 這要自己修改公式去除錯誤

TOP