Board logo

標題: [分享] 從多個分頁資料把合併到主頁 [打印本頁]
作者: kimbal    時間: 2010-8-2 00:36     標題: 從多個分頁資料把合併到主頁

本帖最後由 kimbal 於 2010-8-3 22:06 編輯

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

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

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

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

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

[attach]2152[/attach]

歡迎留意見/討論
  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    時間: 2010-8-2 19:30

本帖最後由 GBKEE 於 2010-8-2 19:31 編輯

回復 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
複製代碼




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