ฟอรัม Excel, VBA และอื่นๆ ของคนไทยเพื่อประโยชน์ของทุกคนในจักรวาล (Forum Excel, VBA and others of Thai people for everyone in the universe.)
http://snasui.com/
การทำเช่นนั้นต้องอาศัย VBA มาช่วยถึงจะสะดวกรวดเร็ว ผมเขียน Code มาเป็นตัวอย่างให้แล้วตามด้านล่าง ดูไฟล์แนบประกอบ
Code: Select all
Sub CollectData()
Dim wb As Workbook, wh As Worksheet
Dim r As Range, s As String
s = ThisWorkbook.Name & ActiveSheet.Name
Application.ScreenUpdating = False
For Each wb In Workbooks
For Each wh In Worksheets
If wb.Name & wh.Name <> s Then
Set r = Workbooks("FileData_20110618.xls").Worksheets("AllData") _
.Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
wh.UsedRange.Copy
r.PasteSpecial xlPasteValues
End If
Next wh
Next wb
r.Offset(0, 6).EntireColumn.SpecialCells(xlCellTypeBlanks) _
.EntireRow.Delete
Application.ScreenUpdating = True
End Sub
Code: Select all
Sub CollectData()
Dim wb As Workbook, wh As Worksheet
Dim r As Range, s As String
s = ThisWorkbook.Name & ActiveSheet.Name
Application.ScreenUpdating = False
For Each wb In Workbooks
For Each wh In wb.Worksheets
If wb.Name & wh.Name <> s Then
Set r = Workbooks("FileData_20110618.xls").Worksheets("AllData") _
.Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
wh.UsedRange.Copy
r.PasteSpecial xlPasteValues
End If
Next wh
Next wb
r.Offset(0, 6).EntireColumn.SpecialCells(xlCellTypeBlanks) _
.EntireRow.Delete
Application.ScreenUpdating = True
End SubCode: Select all
Set r = Workbooks("FileData_20110618.xls").Worksheets("AllData") _
.Range("A" & Rows.Count).End(xlUp).Offset(1, 0)Code: Select all
r.Offset(0, 6).EntireColumn.SpecialCells(xlCellTypeBlanks) _
.EntireRow.Delete