(Macro VBA)ต้องการดึงไฟล์มาทีละหลายๆไฟล์ นำมาแปลงไฟล์ครับ

[parakorn]

เรียนอาจารย์ที่เคารพ และเพื่อนสมาชิกในบอร์ดครับ
เผอิญผมบันทึก Macro การ แปลงไฟล์ จาก .txt มาเป็นไฟล์ Excel แล้วทำการเซพกลับไปที่ โฟลเดอร์เดิมทีละไฟล์
จากโค้ดแนบนี้ อยากขอรบกวน ปรับเป็นการทำงานทีเดียวทุกๆไฟล์ ครับ

Code: Select all

Sub Macro1()
' Macro1 Macro
    ChDir "E:\Input"
    Workbooks.OpenText Filename:="E:\Input\incentive_A.txt", Origin:=874, _
        StartRow:=1, DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _
        ConsecutiveDelimiter:=True, Tab:=True, Semicolon:=False, Comma:=False, _
        Space:=True, Other:=False, FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3 _
        , 1), Array(4, 2), Array(5, 9), Array(6, 1), Array(7, 1), Array(8, 1), Array(9, 1), Array(10, _
        1), Array(11, 1), Array(12, 1), Array(13, 1), Array(14, 1), Array(15, 1), Array(16, 1), _
        Array(17, 1), Array(18, 1), Array(19, 1), Array(20, 1), Array(21, 3), Array(22, 4)), _
        TrailingMinusNumbers:=True
    ActiveWorkbook.SaveAs Filename:="E:\Input\incentive_A.xlsx", FileFormat:= _
        xlOpenXMLWorkbook, CreateBackup:=False
End Sub

[snasui]

ลองแนบตัวอย่างไฟล์และไฟล์ Excel มาด้วยจะได้สะดวกในการทดสอบครับ

[parakorn]

เพิ่มเติมไฟล์แนบครับ

[snasui]

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

Code: Select all

Sub Macro1()
' Macro1 Macro
    Dim strPath As Variant, i As Integer
    Dim fName As String
    
    strPath = Application.GetOpenFilename("Text files(*.txt*),*.txt*", _
        Title:="Please select text files.", MultiSelect:=True)
    If TypeName(strPath) = "Boolean" Then Exit Sub
    
    For i = 1 To UBound(strPath)
        'ChDir "E:\Input"
        fName = VBA.Left(strPath(i), InStr(strPath(i), ".")) & "xlsx"
        Workbooks.OpenText Filename:=strPath(i), Origin:=874, _
            StartRow:=1, DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _
            ConsecutiveDelimiter:=True, Tab:=True, Semicolon:=False, Comma:=False, _
            Space:=True, Other:=False, FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3 _
            , 1), Array(4, 2), Array(5, 9), Array(6, 1), Array(7, 1), Array(8, 1), Array(9, 1), Array(10, _
            1), Array(11, 1), Array(12, 1), Array(13, 1), Array(14, 1), Array(15, 1), Array(16, 1), _
            Array(17, 1), Array(18, 1), Array(19, 1), Array(20, 1), Array(21, 3), Array(22, 4)), _
            TrailingMinusNumbers:=True
        ActiveWorkbook.SaveAs Filename:=fName, FileFormat:= _
            xlOpenXMLWorkbook, CreateBackup:=False
        ActiveWorkbook.Close False
    Next i
    MsgBox "Finish."
End Sub

[parakorn]

ขอบพระคุณครับอาจารย์

[parakorn]

เรียนสอบถามเพิ่มเติมครับ
ผมได้ลองปรับโค้ดที่อาจารย์สอน มาใช้กับงานลักษณ์ เลือกไฟล์หลายๆ มาเรียงต่อกัน
โดยขอเพิ่มเงื่อนไข ใส่ชื่อชีทเพิ่มใน คอลัมภ์สุดท้าย ทุกๆบรรทัด เท่าที่มีข้อมูล ก่อน Copy นำมาต่อกันด้วยครับ

ซึ่งโค้ดที่ได้ลองปรับเบื้องต้น ดังนี้ครับ

Code: Select all

Sub Macro1()
' Macro1 Macro
    Dim strPath As Variant, i As Integer
    Dim fName As String
    
    strPath = Application.GetOpenFilename("Excel files(*.xlsx*),*.xlsx*", _
        Title:="Please select text files.", MultiSelect:=True)
    If TypeName(strPath) = "Boolean" Then Exit Sub
    
    For i = 1 To UBound(strPath)

        fName = VBA.Left(strPath(i), InStr(strPath(i), ".")) & "xlsx"
    Application.Goto Reference:="R2C1"
    Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
    Selection.Cut
    Windows("LetGetFile.xlsx").Activate
    Application.Goto Reference:="R1C1"
    Selection.End(xlDown).Select
    ActiveCell.Offset(1, 0).Range("A1").Select
    ActiveSheet.Paste
        
    Next i
    MsgBox "Finish."
End Sub

ซึ่งยังไม่ได้ผลตามต้องการครับ จึงขอรบกวนด้วยครับ

[snasui]

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

Code: Select all

Sub Macro1()
' Macro1 Macro
    Dim strPath As Variant, i As Integer
    Dim fName As String, nb As Workbook
    Dim tb As Workbook
    
    Set tb = ThisWorkbook
    strPath = Application.GetOpenFilename("Excel files(*.xlsx*),*.xlsx*", _
        Title:="Please select text files.", MultiSelect:=True)
    If TypeName(strPath) = "Boolean" Then Exit Sub
    
    For i = 1 To UBound(strPath)
        Set nb = Workbooks.Open(strPath(i))
        With nb.Worksheets(1)
            .Range("a2").Offset(0, .UsedRange.Columns.Count) _
                .Resize(.UsedRange.Rows.Count - 1, 1).Value = .Name
            .UsedRange.Offset(1, 0).Copy
        End With
        With tb.Sheets(1)
            .Range("a" & .Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
        End With
        Application.CutCopyMode = False
        nb.Close False
    Next i
    MsgBox "Finish."
End Sub

[parakorn]

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

Code: Select all

Sub Macro1()
' Macro1 Macro
    Dim strPath As Variant, i As Integer
    Dim fName As String, nb As Workbook
    Dim tb As Workbook
    
    Set tb = ThisWorkbook
    strPath = Application.GetOpenFilename("Excel files(*.xlsx*),*.xlsx*", _
        Title:="Please select text files.", MultiSelect:=True)
    If TypeName(strPath) = "Boolean" Then Exit Sub
    
    For i = 1 To UBound(strPath)
        Set nb = Workbooks.Open(strPath(i))
        With nb.Worksheets(1)
            .Range("a2").Offset(0, .UsedRange.Columns.Count) _
                .Resize(.UsedRange.Rows.Count - 1, 1).Value = .Name
            .UsedRange.Offset(1, 0).Copy
        End With
        With tb.Sheets(1)
            .Range("a" & .Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
        End With
        Application.CutCopyMode = False
        nb.Close False
    Next i
    MsgBox "Finish."
End Sub

ขอบคุณมากครับ

[parakorn]

ขอสอบถามเพิ่มเติมต่อเลยนะครับ
จาก Code ด้านบน ต้องการจับเงื่อนไขเพิ่มเติมดังนี้ครับ
ที่ Sheet Count คือชีทที่วาง Code สำหรับ Import File
ซึ่งหาก ไฟล์ที่ Import มีการ Import ซ้ำ (มีชื่อไฟล์ ใน Column C)
ต้องการเพิ่ม กล่องโต้ตอบ Yes No เพื่อยืนยันว่าจะ Import หรือไม่ โดยต้องการ Check ทุกๆไฟล์ที่เลือกจะ Import ด้วยนะครับ
ซึ่ง Code ที่ลองปรับไม่สามารถใช้งานได้ครับ

Code: Select all

Sub ImportManyfileToDatabase()
' ImportManyfileToDatabase Macro
    Dim strPath As Variant, i As Integer
    Dim fName As String, nb As Workbook
    Dim tb As Workbook
    
    Set tb = ThisWorkbook
    strPath = Application.GetOpenFilename("Excel files(*.xlsx*),*.xlsx*", _
        Title:="Please select text files.", MultiSelect:=True)
    If TypeName(strPath) = "Boolean" Then Exit Sub
    
    Set C = Column.C: C
    If Find(tb, C, fName) > 0 Then
    MsgBox "This file is already made Are You Continue?", vbYesNo
    If vbYes Then
    For i = 1 To UBound(strPath)
        Set nb = Workbooks.Open(strPath(i))
        With nb.Worksheets(1)
            .Range("a2").Offset(0, .UsedRange.Columns.Count) _
                .Resize(.UsedRange.Rows.Count - 1, 1).Value = .Name
            .UsedRange.Offset(1, 0).Copy
        End With
        With tb.Sheets("Count")
            .Range("a" & .Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
        End With
        Application.CutCopyMode = False
        nb.Close False
    Next i
    MsgBox "Finish."

End If
End Sub

[snasui]

การตรวจสอบว่าซ้ำ ตรวจสอบชื่อไฟล์หรือตรวจสอบข้อมูลครับ

[parakorn]

ตรวจชื่อไฟล์ครับ(เข้าใจว่าต้อง นำมา match กับชื่อไฟล์ที่คีย์แล้วคือ column C)

[snasui]

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

Code: Select all

Sub ExportManyfiletoxlsx()
' ExportManyfiletoxlsx Macro
    Dim strPath As Variant, i As Integer
    Dim fName As String
    
    strPath = Application.GetOpenFilename("Text files(*.txt*),*.txt*", _
        Title:="Please select text files.", MultiSelect:=True)
    If TypeName(strPath) = "Boolean" Then Exit Sub
    
    For i = 1 To UBound(strPath)
        fName = VBA.Left(strPath(i), InStr(strPath(i), ".")) & "xlsx"
        Workbooks.OpenText Filename:=strPath(i), Origin:=874, _
        StartRow:=1, DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _
        ConsecutiveDelimiter:=True, Tab:=True, Semicolon:=False, Comma:=False, _
        Space:=True, Other:=False, FieldInfo:=Array(Array(1, 2), Array(2, 1)), _
        TrailingMinusNumbers:=True

        ActiveWorkbook.SaveAs Filename:=fName, FileFormat:= _
            xlOpenXMLWorkbook, CreateBackup:=False
        ActiveWorkbook.Close False
    Next i
    MsgBox "Finish."
End Sub

Sub ImportManyfileToDatabase()
' ImportManyfileToDatabase Macro
    Dim strPath As Variant, i As Integer
    Dim fName As String, nb As Workbook
    Dim tb As Workbook, ans As Integer
    
    Set tb = ThisWorkbook
    strPath = Application.GetOpenFilename("Excel files(*.xlsx*),*.xlsx*", _
        Title:="Please select text files.", MultiSelect:=True)
    If TypeName(strPath) = "Boolean" Then Exit Sub
    
'    Set C = Column.C: C
'    If Find(tb, C, fName) > 0 Then
'    MsgBox "This File Is Made Are You Continue", vbYesNo
'    If vbYes Then
    For i = 1 To UBound(strPath)
        Set nb = Workbooks.Open(strPath(i))
        With nb.Worksheets(1)
            .Range("a2").Offset(0, .UsedRange.Columns.Count) _
                .Resize(.UsedRange.Rows.Count - 1, 1).Value = .Name
            .UsedRange.Offset(1, 0).Copy
        End With
        With tb.Sheets("Count")
            If Application.CountIf(.Range("c:c"), nb.Name) Then
                ans = MsgBox("This File Is Made Are You Continue.", vbYesNo)
                If ans = vbYes Then
                    .Range("a" & .Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
                End If
            Else
                .Range("a" & .Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
            End If
        End With
        Application.CutCopyMode = False
        nb.Close False
    Next i
    MsgBox "Finish."

'End If
End Sub

[parakorn]

ลองปรับแล้ว ยังสามารถ Import ไฟล์เดิมได้ครับผม

[snasui]

ปรับบรรทัด If ที่ใช้เช็คชื่อไฟล์เป็นด้านล่างครับ

If Application.CountIf(.Range("c:c"), VBA.Left(nb.Name, InStrRev(nb.Name, ".") - 1)) Then

[parakorn]

ปรับบรรทัด If ที่ใช้เช็คชื่อไฟล์เป็นด้านล่างครับ

If Application.CountIf(.Range("c:c"), VBA.Left(nb.Name, InStrRev(nb.Name, ".") - 1)) Then

Complete แล้วครับ

[parakorn]

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

Code: Select all

Sub Macro1()
' Macro1 Macro
    Dim strPath As Variant, i As Integer
    Dim fName As String
    
    strPath = Application.GetOpenFilename("Text files(*.txt*),*.txt*", _
        Title:="Please select text files.", MultiSelect:=True)
    If TypeName(strPath) = "Boolean" Then Exit Sub
    
    For i = 1 To UBound(strPath)
        'ChDir "E:\Input"
        fName = VBA.Left(strPath(i), InStr(strPath(i), ".")) & "xlsx"
        Workbooks.OpenText Filename:=strPath(i), Origin:=874, _
            StartRow:=1, DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _
            ConsecutiveDelimiter:=True, Tab:=True, Semicolon:=False, Comma:=False, _
            Space:=True, Other:=False, FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3 _
            , 1), Array(4, 2), Array(5, 9), Array(6, 1), Array(7, 1), Array(8, 1), Array(9, 1), Array(10, _
            1), Array(11, 1), Array(12, 1), Array(13, 1), Array(14, 1), Array(15, 1), Array(16, 1), _
            Array(17, 1), Array(18, 1), Array(19, 1), Array(20, 1), Array(21, 3), Array(22, 4)), _
            TrailingMinusNumbers:=True
        ActiveWorkbook.SaveAs Filename:=fName, FileFormat:= _
            xlOpenXMLWorkbook, CreateBackup:=False
        ActiveWorkbook.Close False
    Next i
    MsgBox "Finish."
End Sub

ขอย้อนกลับมาพัฒนาโค้ดนี้ต่อนะครับ ผมต้องการ นำข้อมูลชีทที่ชื่อไฟล์ ไม่ได้ต่อท้ายด้วย A (คือ B,C,D,E เรียงตามลำดับ) Copy มาวางที่ ไฟล์ที่มีชื่อต่อท้ายด้วย A แล้วให้ทำการ เปลี่ยนชื่อชีทแลพ ชื่อไฟล์ โดยลบ _A ออกไป(รวมถึงชื่อไฟล์ด้วยครับ) แล้วเซพ

เช่น Incentive_A , Incentive_B ข้อมูล ไฟล์ Incentive_B(C,D,E.....) ให้ Copy ไปต่อท้าย Incentive_A
แล้วแก้ไขชื่อไฟล์ และ ชื่อชีท จาก Incentive_A เป็น Incentive
แล้วเซพ

แล้วเริ่มทำงานกับ ชุด Incentive2_A , B ต่อไปในลักษณะเดิมครับ

Code: Select all

Sub Macro1()
' Macro1 Macro
    Dim strPath As Variant, i As Integer
    Dim fName As String
    
    strPath = Application.GetOpenFilename("Text files(*.txt*),*.txt*", _
        Title:="Please select text files.", MultiSelect:=True)
    If TypeName(strPath) = "Boolean" Then Exit Sub
    
    For i = 1 To UBound(strPath)
        'ChDir "E:\Input"
        fName = VBA.Left(strPath(i), InStr(strPath(i), ".")) & "xlsx"
        Workbooks.OpenText Filename:=strPath(i), Origin:=874, _
            StartRow:=1, DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _
            ConsecutiveDelimiter:=True, Tab:=True, Semicolon:=False, Comma:=False, _
            Space:=True, Other:=False, FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3 _
            , 1), Array(4, 2), Array(5, 9), Array(6, 1), Array(7, 1), Array(8, 1), Array(9, 1), Array(10, _
            1), Array(11, 1), Array(12, 1), Array(13, 1), Array(14, 1), Array(15, 1), Array(16, 1), _
            Array(17, 1), Array(18, 1), Array(19, 1), Array(20, 1), Array(21, 3), Array(22, 4)), _
            TrailingMinusNumbers:=True
    
    Windows("incentive_B.txt").Activate
    Application.Goto Reference:="OFFSET(R1C1,1,,COUNTA(C1),COUNTA(R2))"
    Selection.Copy
    Windows("incentive_A.txt").Activate
    Application.Goto Reference:="OFFSET(R1C1,COUNTA(C1)+1,,,)"
    ActiveSheet.Paste
    Sheets("incentive_A").Name = "incentive"
    
        'ActiveWorkbook.SaveAs Filename:=fName, FileFormat:= _
            'xlOpenXMLWorkbook, CreateBackup:=False
        'ActiveWorkbook.Close False
    
    Next i
    MsgBox "Finish."
End Sub

[snasui]

แนบไฟล์โปรแกรมล่าสุดมาด้วยจะได้เขียนต่อไปจากนั้นครับ

[parakorn]

ไฟล์แนบครับ

[snasui]

ต้องการ นำข้อมูลชีทที่ชื่อไฟล์ ไม่ได้ต่อท้ายด้วย A (คือ B,C,D,E เรียงตามลำดับ) Copy มาวางที่ ไฟล์ที่มีชื่อต่อท้ายด้วย A แล้วให้ทำการ เปลี่ยนชื่อชีทแลพ ชื่อไฟล์ โดยลบ _A ออกไป(รวมถึงชื่อไฟล์ด้วยครับ) แล้วเซพ

อ่านแล้วยังไม่กระจ่างครับ เนื่องจากไม่พบไฟล์ที่ไม่มีต่อท้ายด้วยอักขระ A, B ไฟล์ที่ Zip มามี 4 ไฟล์คือ incentive_A.txt, incentive2_A.txt, incentive_ฺB.txt และ incentive2_B.txt

จากไฟล์ดังกล่าว ช่วยลำดับการทำงานมาอีกครั้งเพื่อจะได้เข้าใจตรงกันครับ

[parakorn]

แนบไฟล์มาใหม่ครับผม

Code: Select all

Sub Macro1()
' Macro1 Macro
    Dim strPath As Variant, i As Integer
    Dim fName As String
    
    strPath = Application.GetOpenFilename("Text files(*.txt*),*.txt*", _
        Title:="Please select text files.", MultiSelect:=True)
    If TypeName(strPath) = "Boolean" Then Exit Sub
    
    For i = 1 To UBound(strPath)

        fName = VBA.Left(strPath(i), InStr(strPath(i), ".")) & "xlsx"
        Workbooks.OpenText Filename:=strPath(i), Origin:=874, _
            StartRow:=1, DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _
            ConsecutiveDelimiter:=True, Tab:=True, Semicolon:=False, Comma:=False, _
            Space:=True, Other:=False, FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3 _
            , 1), Array(4, 2), Array(5, 9), Array(6, 1), Array(7, 1), Array(8, 1), Array(9, 1), Array(10, _
            1), Array(11, 1), Array(12, 1), Array(13, 1), Array(14, 1), Array(15, 1), Array(16, 1), _
            Array(17, 1), Array(18, 1), Array(19, 1), Array(20, 1), Array(21, 3), Array(22, 4)), _
            TrailingMinusNumbers:=True
            
        Next i

    Windows("incentive_B.txt").Activate
    Application.Goto Reference:="OFFSET(R1C1,1,,COUNTA(C1)-1,COUNTA(R2))"
    Selection.Copy
    Windows("incentive_A.txt").Activate
    Application.Goto Reference:="OFFSET(R1C1,COUNTA(C1)+1,,,)"
    ActiveSheet.Paste
        Windows("incentive_C.txt").Activate
    Application.Goto Reference:="OFFSET(R1C1,1,,COUNTA(C1)-1,COUNTA(R2))"
    Selection.Copy
    Windows("incentive_A.txt").Activate
    Application.Goto Reference:="OFFSET(R1C1,COUNTA(C1)+1,,,)"
    ActiveSheet.Paste
        Windows("incentive_D.txt").Activate
    Application.Goto Reference:="OFFSET(R1C1,1,,COUNTA(C1)-1,COUNTA(R2))"
    Selection.Copy
    Windows("incentive_A.txt").Activate
    Application.Goto Reference:="OFFSET(R1C1,COUNTA(C1)+1,,,)"
    ActiveSheet.Paste
    Sheets("incentive_A").Name = "incentive"
    
        'ActiveWorkbook.SaveAs Filename:=fName, FileFormat:= _
            'xlOpenXMLWorkbook, CreateBackup:=False
        'ActiveWorkbook.Close False
    
    MsgBox "Finish."
End Sub