RSS

การรวมข้อมูลจากหลายชีทด้วย VBA

15 Oct

กรณีต้องการรวมข้อมูลจากหลายชีทโดยนำข้อมูลมาต่อกันด้วยสูตรนั้นสามารถศึกษาได้จาก การนำข้อมูลจากหลาย Sheet มาต่อกันใน Sheet เดียว สำหรับที่จะนำเสนอต่อไปนี้เป็นนำข้อมูลจากหลายชีทมารวมในชีทเดียวกันด้วย VBA โดยทำการจัดเรียงใหม่และแทรกบรรทัดผลรวมของแต่ละชุดไว้ให้ด้วย ซึ่งข้อมูลต้นแหล่งและข้อมูลเป้าหมายมีลักษณะตามภาพด้านล่างครับ

ภาพแสดงข้อมูลต้นแหล่งและลักษณะข้อมูลเป้าหมายที่ต้องการ

CollectDataAndFormatFromMultipleSheets

เราสามารถใช้ VBA ในการดำเนินการดังกล่าว โดยเขียน 3 Procedure แยกหน้าที่กันดังนี้

  1. CollectData เพื่อนำข้อมูลจากแต่ละชีทมาวางต่อกันใน Sheet4 และใช้เป็น Procedure ในการ Run Code
  2. SortData เพื่อจัดเรียงข้อมูลใหม่ตามคอลัมน์ D (ชื่อประเภท) เป็น Sub Procedure ถูกเรียกใช้จากข้อ 1
  3. InsertRow เพื่อแทรกบรรทัด, สรุปยอดรวมและทำการจัด Format เป็น Sub Procedure ถูกเรียกใช้จากข้อ 1

ตัวอย่าง VBA Code

Option Explicit

Sub CollectData()
Dim ws As Worksheet
Dim r As Range
Dim rTarget As Range
Application.ScreenUpdating = False
For Each ws In Worksheets
If ws.Name <> "Sheet4" Then
With Sheets("Sheet4")
Set rTarget = .Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
End With
Set r = ws.Range("A2", ws.Range("A" & Rows.Count).End(xlUp))
r.SpecialCells(xlCellTypeConstants).EntireRow.Copy
rTarget.PasteSpecial xlPasteValues
End If
Next ws
SortData
InsertRow
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub

Sub SortData()
Dim r As Range
Dim rs As Range
With Sheets("Sheet4")
Set r = .Range("A1", .Range("H" & Rows.Count).End(xlUp))
Set rs = r.Cells(2, 1).Offset(0, 3).Resize(r.Count - 1, 1)
.Sort.SortFields.Clear
.Sort.SortFields.Add Key:=rs _
, SortOn:=xlSortOnValues, Order:=xlAscending, _
DataOption:=xlSortNormal
With .Sort
.SetRange r
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End With
End Sub

Sub InsertRow()
Dim r As Range, rAll As Range
Dim rFmt As Range, rsHead As Range
Dim rtHead As Range, rInsert As Range
With Sheets("Sheet1")
Set rFmt = .Range("A2")
Set rsHead = .Range("A1:H1")
End With
With Sheets("Sheet4")
Set rtHead = .Range("A1")
Set rAll = .Range("D2", .Range("D" & Rows.Count).End(xlUp))
For Each r In rAll
If r <> r.Offset(1, 0) Then
r.Offset(1, 5) = True
End If
Next r
Set rInsert = .Range("I:I").SpecialCells(xlCellTypeConstants)
For Each r In rInsert
r.Resize(2, 1).EntireRow.Insert shift:=xlShiftDown
r.Offset(-2, -7) = "Total"
r.Offset(-2, -4).Formula = "=sum(" & r.Offset(-3, -4).Address & ":" & _
r.Offset(-3, -4).End(xlUp).Address & ")"
Set r = r.Offset(-2, -4)
r = Application.ConvertFormula(r.FormulaR1C1, xlR1C1, xlA1, xlRelative)
r.Resize(1, 4).FillRight
rFmt.Copy
r.CurrentRegion.PasteSpecial xlPasteFormats
Next r
.Range("I:I").Clear
End With
rsHead.Copy rtHead
End Sub

 

ตามแสดงตัวอย่างการใช้งาน

CollectDataResults

 
 
Leave a comment

Posted by on 15/10/2011 in Multi Sheet, Rerange, Subtotal

 

Leave a Reply

Fill in your details below or click an icon to log in:

WordPress.com Logo

You are commenting using your WordPress.com account. Log Out / Change )

Twitter picture

You are commenting using your Twitter account. Log Out / Change )

Facebook photo

You are commenting using your Facebook account. Log Out / Change )

Google+ photo

You are commenting using your Google+ account. Log Out / Change )

Connecting to %s

 
%d bloggers like this: