[VBA] ต่อไฟล์ auto แนว Colunm (แนวตั้ง)

[kannaree]

สวัสดีค่ะ
1. อยากสอบถามว่าถ้าต้องการเอาไฟล์มาต่อกัน แนวตั้งจะต้องแก้ไขโค้ดอย่างไรค่ะ
ลองดูแล้วทำไม่ได้ ได้แต่แนวนอนค่ะ
2. อีกอย่างค่ะ พอลอง test ดูแล้วลบข้อมูลเดิม กดเทสใหม่ ข้อมูลกลับไปต่อท้ายเป็น บรรทัดที่ไม่มีข้อมูลบรรทัดสุดท้าย
ข้อมูลไม่ขึ้นมาแสดงตรง b1

12.png

Code: Select all

Private Sub CommandButton1_Click()
Set cell_to_paste_next_dataset = Cells(1, 1)
 Set active_workbook = ActiveWorkbook
 Set active_sheet = Sheet2
 Application.DisplayAlerts = False

 File_Path = TextBox1.Value
 strName = Dir(File_Path & "\" & "*.xls")

 Do While strName <> vbNullString

 If active_workbook.Name <> strName And strName <> "" Then
 Workbooks.Open Filename:=File_Path & "\" & strName
 Set dataset_workbook = ActiveWorkbook
 Range(ActiveCell.SpecialCells(xlLastCell), Cells(1)).Copy
 active_sheet.Activate
 Cells(ActiveCell.SpecialCells(xlLastCell).Row, 1).Offset(1, 0).Select
 ActiveSheet.Paste
 dataset_workbook.Close
 End If
 strName = Dir
 Loop
 Application.DisplayAlerts = True
End Sub

TestmergeFile.xlsm

[snasui]

ตัวอย่างการปรับ Code ครับ

Code: Select all

'...other code
Do While strName <> vbNullString
    If active_workbook.Name <> strName And strName <> "" Then
    Workbooks.Open Filename:=File_Path & "\" & strName
    Set dataset_workbook = ActiveWorkbook
    Range(ActiveCell.SpecialCells(xlLastCell), Cells(1)).Copy
    active_sheet.Activate
    active_sheet.Range("b" & Rows.Count).End(xlUp).Offset(1, 0).Select
    ActiveSheet.Paste
    dataset_workbook.Close
    End If
    strName = Dir
Loop
'...other code

[kannaree]

ขอบคุณมากค่ะอาจารย์ แต่ลองทดสอบดูแล้ว ตารางไม่ต่อกันค่ะ เหมือนจะ copy วางซ้ำที่เดิม

19.png

อยากให้ต่อกันตามรูปด้านล่างค่ะ

20.png

[kannaree]

หนูสามารถทำได้แล้ว แต่โค้ดไม่ค่อยสวยงามเท่าไหร่พอดีไม่ค่อยมีพื้นฐาน มีวิธีปรับโค้ดให้ดีกว่านี้ไหมค่ะ

Code: Select all

Do While strName <> vbNullString
    If active_workbook.Name <> strName And strName <> "" Then
    Workbooks.Open Filename:=File_Path & "\" & strName
    Set dataset_workbook = ActiveWorkbook
    Range(ActiveCell.SpecialCells(xlLastCell), Cells(1)).Copy
    active_sheet.Activate
    
    
    Dim i As Long
    Dim r As Long
    Dim j As Long
        
    
    i = Sheet3.Cells(2, Sheet3.Columns.Count).End(xlToLeft).Column
    r = i - 2

    MsgBox ("" & i)
    
    For j = 0 To i
    
    active_sheet.Range("b" & Rows.Count).End(xlUp).Offset(1, j).Select
    ActiveSheet.Paste
    j = j + r
    Next j
    dataset_workbook.Close
    End If
    strName = Dir
    Loop

[snasui]

กรณี Code ทำงานไม่ผิดพลาดยังไม่จำเป็นต้องรีบปรับครับ เมื่อใดทีทำงานผิดพลาดค่อยถามมาอีกทีครับ