[分享] 從多個分頁資料把合併到主頁 VBA, 資料合併

kimbal

把分頁資料合併到主頁的方法

單純把欄抄出,不做彙總.
彙總的話, 請先了解內建"樞紐表"和"合併彙總"用法

欄位位置不拘,但A欄為主鍵(可手工調節),

分頁可以不放欄位.
如果欄名跟主頁不一致,可在主頁欄位註解上填上,用豆號分隔

除主鍵外其他欄內容可以為空.

下載 (152.49 KB)

2010-8-2 00:38

歡迎留意見/討論

1. Option Explicit
   
2.    
   
3. Public Sub refresh_all()
   
4.     Dim shtCurr As Worksheet
   
5.     Dim rngHeader As Range, rngResult As Range, strHeaderArray, strHeader
   
6.     Dim lngLastPosition As Long
   
7.     With ActiveSheet
   
8.         .[A1].CurrentRegion.Offset(1).Clear
   
9.         lngLastPosition = 2
   
10.         For Each shtCurr In Sheets
    
11.             If shtCurr.Name <> .Name Then
    
12.                 For Each rngHeader In .[A1].CurrentRegion.Rows(1).Cells
    
13.                     If (rngHeader.Comment Is Nothing) Then
    
14.                         strHeaderArray = Split(rngHeader.Value)
    
15.                     Else
    
16.                         strHeaderArray = Split(rngHeader.Comment.Text & "," & rngHeader.Value, ",")
    
17.                     End If
    
18.                     For Each strHeader In strHeaderArray
    
19.                         Set rngResult = shtCurr.Rows(1).Find(strHeader, LookIn:=xlValues, LookAt:=xlWhole)
    
20.                         If Not rngResult Is Nothing Then
    
21.                             shtCurr.Range(rngResult.Offset(1), _
    
22.                                 rngResult.Offset(rngResult.CurrentRegion.SpecialCells(xlCellTypeLastCell).Row - 1)).Copy Destination:= _
    
23.                                     .Cells(lngLastPosition, rngHeader.Column)
    
24.                             Exit For
    
25.                         End If
    
26.                     Next
    
27.                 Next
    
28.                 lngLastPosition = .Cells(Rows.Count, 1).End(xlUp).Row + 1
    
29.             End If
    
30.         Next
    
31.     End With
    
32. End Sub

複製代碼

感謝GBKEE大出手相助簡化, 借花敬佛, 再加些東西.

GBKEE

回復 1#把分頁資料合併到主頁的方法
單純把欄抄出,不做彙總. kimbal板主

1. Public Sub refresh_all()
   
2. Dim Sh As Worksheet, R As Range, F As Range
   
3. With ActiveSheet
   
4. .[A1].CurrentRegion.Offset(1).Clear
   
5. For Each R In .[A1].CurrentRegion.Rows(1).Cells
   
6. For Each Sh In Sheets
   
7. If Sh.Name <> .Name Then
   
8. Set F = Sh.Rows(1).Find(R, LookIn:=xlValues, LookAt:=xlWhole)
   
9. Sh.Range(F.Offset(1), F.End(xlDown)).Copy .Cells(Rows.Count, R.Column).End(xlUp).Offset(1)
   
10. End If
    
11. Next
    
12. Next
    
13. End With
    
14. End Sub

複製代碼