snasui.com ยินดีต้อนรับ ยินดีต้อนรับสู่กระดานถามตอบ Excel and VBA และอื่น ๆ ที่เป็นมิตรกับทุกท่าน มีไฟล์แนบมหาศาล ช่วยให้ท่านค้นหาและติดตามศึกษาได้โดยง่าย สมาชิกท่านใดที่ยังไม่ได้ระบุ Version ของ Excel ที่ใช้งานจริง สามารถทำตาม Link นี้เพื่อจะได้รับคำตอบที่ตรงกับ Version ของท่านครับ ระบุ Version ของ Excel
เรียนอาจารย์และพี่ๆเพื่อนๆสมาชิก
ผมลองนำ VBA Code ของอาจารย์มาใช้รวมข้อมูลจากหลายๆไฟล์แล้วขึ้น Eror ตามภาพตัวอย่างครับ โดยในแต่ล่ะ File จะมีอยู่หลายชีทแต่ต้องการข้อมูลจากชีทที่ชื่อ ColecData ของแต่ล่ะ File เท่านั้นมารวมกัน ช่วยแนะนำจุดที่ต้องปรับ Code เพิ่มเติมให้ผมหน่อยครับ Sub CollectDataFromMultipleFiles()
Dim wb As Workbook, s As Worksheet, db As Worksheet
Dim strPath As Variant, i As Integer, f As Byte
strPath = Application.GetOpenFilename( _
FileFilter:="Excel File (*.xls*),*.xls*", _
MultiSelect:=True)
If TypeName(strPath) = "Boolean" Then Exit Sub
Set db = ThisWorkbook.Sheets(1)
db.UsedRange.ClearContents
Application.ScreenUpdating = False
For i = 1 To UBound(strPath)
For Each s In wb.Worksheets
f = IIf(db.Range("a1").Value = "", 1, 0)
If s.Range("a1").Value <> "" Then
s.UsedRange.Offset(f, 0).Copy
With db
.Range("a" & .Rows.Count).End(xlUp).Offset(f, 0) _
.PasteSpecial xlPasteValues
End With
End If
Next s
wb.Close
Application.CutCopyMode = False
Next i
Application.ScreenUpdating = True
MsgBox "Finished", vbInformation
End Sub
You do not have the required permissions to view the files attached to this post.
Sub CollectDataFromMultipleFiles()
Dim wb As Workbook, s As Worksheet, db As Worksheet
Dim strPath As Variant, i As Integer, f As Byte
strPath = Application.GetOpenFilename( _
FileFilter:="Excel File (*.xls*),*.xls*", _
MultiSelect:=True)
If TypeName(strPath) = "Boolean" Then Exit Sub
Set db = ThisWorkbook.Sheets(1)
db.UsedRange.ClearContents
Application.ScreenUpdating = False
For i = 1 To UBound(strPath)
For Each s In wb.Worksheets
f = IIf(db.Range("a1").Value = "", 1, 0)
If s.Range("a1").Value <> "" Then
s.UsedRange.Offset(f, 0).Copy
With db
.Range("a" & .Rows.Count).End(xlUp).Offset(f, 0) _
.PasteSpecial xlPasteValues
End With
End If
Next s
wb.Close
Application.CutCopyMode = False
Next i
Application.ScreenUpdating = True
MsgBox "Finished", vbInformation
End Sub
You do not have the required permissions to view the files attached to this post.
Sub CollectDataFromMultipleFiles()
Dim wb As Workbook, s As Worksheet, db As Worksheet
Dim strPath As Variant, i As Integer, f As Byte
strPath = Application.GetOpenFilename( _
FileFilter:="Excel File (*.xls*),*.xls*", _
MultiSelect:=True)
If TypeName(strPath) = "Boolean" Then Exit Sub
Set db = ThisWorkbook.Sheets(1)
db.UsedRange.ClearContents
Application.ScreenUpdating = False
For i = 1 To UBound(strPath)
For Each s In wb.Worksheets
f = IIf(db.Range("a1").Value = "", 1, 0)
If s.Range("a1").Value <> "" Then
s.UsedRange.Offset(f, 0).Copy
With db
.Range("a" & .Rows.Count).End(xlUp).Offset(f, 0) _
.PasteSpecial xlPasteValues
End With
End If
Next s
wb.Close
Application.CutCopyMode = False
Next i
Application.ScreenUpdating = True
MsgBox "Finished", vbInformation
End Sub
file สำหรับรวมข้อมูลครับ
You do not have the required permissions to view the files attached to this post.
Sub CollectDataFromMultipleFiles()
Dim wb As Workbook, s As Worksheet, db As Worksheet
Dim strPath As Variant, i As Integer, f As Byte
strPath = Application.GetOpenFilename( _
FileFilter:="Excel File (*.xls*),*.xls*", _
MultiSelect:=True)
If TypeName(strPath) = "Boolean" Then Exit Sub
Set db = ThisWorkbook.Sheets(1)
db.UsedRange.ClearContents
Application.ScreenUpdating = False
For i = 1 To UBound(strPath)
Set wb = Workbooks.Open(strPath(1))
For Each s In wb.Worksheets
f = IIf(db.Range("a1").Value = "", 1, 0)
If s.Range("a1").Value <> "" Then
s.UsedRange.Offset(f, 0).Copy
With db
.Range("a" & .Rows.Count).End(xlUp).Offset(f, 0) _
.PasteSpecial xlPasteValues
End With
End If
Next s
wb.Close False
Application.CutCopyMode = False
Next i
Application.ScreenUpdating = True
MsgBox "Finished", vbInformation
End Sub
You do not have the required permissions to view the files attached to this post.
Sub CollectDataFromMultipleFiles()
Dim wb As Workbook, s As Worksheet, db As Worksheet
Dim strPath As Variant, i As Integer, f As Byte
strPath = Application.GetOpenFilename( _
FileFilter:="Excel File (*.xls*),*.xls*", _
MultiSelect:=True)
If TypeName(strPath) = "Boolean" Then Exit Sub
Set db = ThisWorkbook.Sheets(1)
db.UsedRange.ClearContents
Application.ScreenUpdating = False
For i = 1 To UBound(strPath)
Set wb = Workbooks.Open(strPath(1))
For Each s In wb.Worksheets
f = IIf(db.Range("a1").Value = "", 1, 0)
If s.Range("a1").Value <> "" Then
s.UsedRange.Offset(f, 0).Copy
With db
.Range("a" & .Rows.Count).End(xlUp).Offset(f, 0) _
.PasteSpecial xlPasteValues
End With
End If
Next s
wb.Close False
Application.CutCopyMode = False
Next i
Application.ScreenUpdating = True
MsgBox "Finished", vbInformation
End Sub
Sub CollectDataFromMultipleFiles()
Dim wb As Workbook, s As Worksheet, db As Worksheet
Dim strPath As Variant, i As Integer, f As Byte
strPath = Application.GetOpenFilename( _
FileFilter:="Excel File (*.xls*),*.xls*", _
MultiSelect:=True)
If TypeName(strPath) = "Boolean" Then Exit Sub
Set db = ThisWorkbook.Sheets(1)
db.UsedRange.ClearContents
Application.ScreenUpdating = False
For i = 1 To UBound(strPath)
Set wb = Workbooks.Open(strPath(i)) '<<<ตรงนี้เปลี่ยนเป็น i ตามอาจารย์แจ้งครับ
For Each s In wb.Worksheets
f = IIf(db.Range("a1").Value = "", 1, 0)
If s.Range("a1").Value <> "" Then
s.UsedRange.Offset(f, 0).Copy
With db
.Range("a" & .Rows.Count).End(xlUp).Offset(f, 0) _
.PasteSpecial xlPasteValues
End With
End If
Next s
wb.Close False
Application.CutCopyMode = False
Next i
Application.ScreenUpdating = True
MsgBox "Finished", vbInformation
End Sub
Sub CollectDataFromMultipleFiles()
Dim wb As Workbook, s As Worksheet, db As Worksheet
Dim strPath As Variant, i As Integer, f As Byte
strPath = Application.GetOpenFilename( _
FileFilter:="Excel File (*.xls*),*.xls*", _
MultiSelect:=True)
If TypeName(strPath) = "Boolean" Then Exit Sub
Set db = ThisWorkbook.Sheets(1)
db.UsedRange.ClearContents
Application.ScreenUpdating = False
For i = 1 To UBound(strPath)
Set wb = Workbooks.Open(strPath(i))
For Each s In wb.Worksheets
f = IIf(db.Range("a1").Value = "", 1, 0)
If s.Range("a1").Value <> "" Then
s.UsedRange.Offset(f, 0).Copy
With db
.Range("a" & .Rows.Count).End(xlUp).Offset(f, 0) _
.PasteSpecial xlPasteValues
End With
End If
Next s
wb.Close False
Application.CutCopyMode = False
Next i
Application.ScreenUpdating = True
MsgBox "Finished", vbInformation
End Sub
Sub CollectDataFromMultipleFiles()
Dim wb As Workbook, s As Worksheet, db As Worksheet
Dim strPath As Variant, i As Integer, f As Byte
Application.DisplayAlerts = False
strPath = Application.GetOpenFilename( _
FileFilter:="Excel File (*.xls*),*.xls*", _
MultiSelect:=True)
If TypeName(strPath) = "Boolean" Then Exit Sub
Set db = ThisWorkbook.Sheets(1)
db.UsedRange.ClearContents
Application.ScreenUpdating = False
For i = 1 To UBound(strPath)
Set wb = Workbooks.Open(strPath(i))
' For Each s In wb.Worksheets
Set s = wb.Sheets("CollecData")
f = IIf(db.Range("a1").Value = "", 1, 0)
If s.Range("a1").Value <> "" Then
s.UsedRange.Offset(f, 0).Copy
With db
.Range("a" & .Rows.Count).End(xlUp).Offset(f, 0) _
.PasteSpecial xlPasteValues
End With
End If
' Next s
wb.Close False
Application.CutCopyMode = False
Next i
Application.ScreenUpdating = True
Application.DisplayAlerts = True
MsgBox "Finished", vbInformation
End Sub
Sub CollectDataFromMultipleFiles()
Dim wb As Workbook, s As Worksheet, db As Worksheet
Dim strPath As Variant, i As Integer, f As Byte
Application.DisplayAlerts = False
strPath = Application.GetOpenFilename( _
FileFilter:="Excel File (*.xls*),*.xls*", _
MultiSelect:=True)
If TypeName(strPath) = "Boolean" Then Exit Sub
Set db = ThisWorkbook.Sheets(1)
db.UsedRange.ClearContents
Application.ScreenUpdating = False
For i = 1 To UBound(strPath)
Set wb = Workbooks.Open(strPath(i))
' For Each s In wb.Worksheets
Set s = wb.Sheets("CollecData")
f = IIf(db.Range("a1").Value = "", 1, 0)
If s.Range("a1").Value <> "" Then
s.UsedRange.Offset(f, 0).Copy
With db
.Range("a" & .Rows.Count).End(xlUp).Offset(f, 0) _
.PasteSpecial xlPasteValues
End With
End If
' Next s
wb.Close False
Application.CutCopyMode = False
Next i
Application.ScreenUpdating = True
Application.DisplayAlerts = True
MsgBox "Finished", vbInformation
End Sub
Sub CollectDataFromMultipleFiles()
Dim wb As Workbook, s As Worksheet, db As Worksheet
Dim strPath As Variant, i As Integer, f As Byte
Application.DisplayAlerts = False
strPath = Application.GetOpenFilename( _
FileFilter:="Excel File (*.xls*),*.xls*", _
MultiSelect:=True)
If TypeName(strPath) = "Boolean" Then Exit Sub
Set db = ThisWorkbook.Sheets(1)
db.UsedRange.ClearContents
Application.ScreenUpdating = False
For i = 1 To UBound(strPath)
Set wb = Workbooks.Open(strPath(i))
' For Each s In wb.Worksheets
Set s = wb.Sheets("CollecData")
f = IIf(db.Range("a1").Value = "", 1, 0)
If s.Range("a1").Value <> "" Then
s.UsedRange.Offset(f, 0).Copy
With db
.Range("a" & .Rows.Count).End(xlUp).Offset(f, 0) _
.PasteSpecial xlPasteValues
End With
End If
' Next s
wb.Close False
Application.CutCopyMode = False
Next i
Application.ScreenUpdating = True
Application.DisplayAlerts = True
MsgBox "Finished", vbInformation
End Sub
Sub CollectDataFromMultipleFiles()
Dim wb As Workbook, s As Worksheet, db As Worksheet
Dim strPath As Variant, i As Integer, f As Byte
Application.DisplayAlerts = False
strPath = Application.GetOpenFilename( _
FileFilter:="Excel File (*.xls*),*.xls*", _
MultiSelect:=True)
If TypeName(strPath) = "Boolean" Then Exit Sub
Set db = ThisWorkbook.Sheets(1)
db.UsedRange.ClearContents
Application.ScreenUpdating = False
For i = 1 To UBound(strPath)
Set wb = Workbooks.Open(strPath(i))
' For Each s In wb.Worksheets
Set s = wb.Sheets("CollecData")
f = IIf(db.Range("a1").Value = "", 1, 0)
If s.Range("a1").Value <> "" Then
s.UsedRange.Offset(f, 0).Copy
With db
.Range("a" & .Rows.Count).End(xlUp).Offset(f, 0) _
.PasteSpecial xlPasteValues
End With
End If
' Next s
wb.Close False
Application.CutCopyMode = False
Next i
Application.ScreenUpdating = True
Application.DisplayAlerts = True
MsgBox "Finished", vbInformation
End Sub
snasui.com ยินดีต้อนรับ 
สมาชิกท่านใดที่ยังไม่ได้ระบุ Version ของ Excel ที่ใช้งานจริง สามารถทำตาม Link นี้เพื่อจะได้รับคำตอบที่ตรงกับ Version ของท่านครับ 
โปรดทราบ 
