Snasui Excel Forum

Code: Select all

Sub CollectData()
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) 'StrPath คือ Excel
   
If TypeName(StrPath) = "Boolean" Then Exit Sub   'ถ้าไม่เลือกให้ออก
Set db = ThisWorkbook.Sheets(1)  'db คือ workbook
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 = "", 0, 1)  'ถ้านำข้อมูลมาวางแล้วไม่ต้องเอาหัวคอลัม ถ้ายังไม่มีให้เอาหัวมาด้วย
     If s.Range("a1").Value <> "" Then    'ถ้าเอ1ไม่เท่ากับค่าว่าง
        s.UsedRange.Offset(f, 0).Copy    'ให้คัดลอกมาวาง
      With db   'วางที่sheet1
          .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

Code: Select all

'Other code
Set wb = Workbooks.Open(StrPath(i))
For Each s In wb.Worksheets
    if s.name <> "Sheet1" then
        f = IIf(db.Range("a1").Value = "", 0, 1)  'ถ้านำข้อมูลมาวางแล้วไม่ต้องเอาหัวคอลัม ถ้ายังไม่มีให้เอาหัวมาด้วย
        If s.Range("a1").Value <> "" Then    'ถ้าเอ1ไม่เท่ากับค่าว่าง
            s.UsedRange.Offset(f, 0).Copy    'ให้คัดลอกมาวาง
            With db   'วางที่sheet1
                .Range("a" & .Rows.Count).End(xlUp).Offset(f, 0) _
                .PasteSpecial xlPasteValues
            End With
        End If
    end if
Next s
'Other code

Code: Select all

Dim StrPath As Variant