Snasui Excel Forum

คลังคำตอบแห่งความรู้จากคนไทย เพื่อโลกที่ต้องการเข้าใจในสิ่งเล็ก ๆ อย่างลึกซึ้ง
https://www.snasui.com/

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

https://www.snasui.com/viewtopic.php?t=12173

Page 1 of 2

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

Posted: Sun Sep 03, 2017 6:08 pm
by parakorn
เรียนอาจารย์ที่เคารพ และเพื่อนสมาชิกในบอร์ดครับ
เผอิญผมบันทึก Macro การ แปลงไฟล์ จาก .txt มาเป็นไฟล์ Excel แล้วทำการเซพกลับไปที่ โฟลเดอร์เดิมทีละไฟล์
จากโค้ดแนบนี้ อยากขอรบกวน ปรับเป็นการทำงานทีเดียวทุกๆไฟล์ ครับ :D

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

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

Posted: Sun Sep 03, 2017 7:22 pm
by snasui
:D ลองแนบตัวอย่างไฟล์และไฟล์ Excel มาด้วยจะได้สะดวกในการทดสอบครับ

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

Posted: Sun Sep 03, 2017 7:56 pm
by parakorn
เพิ่มเติมไฟล์แนบครับ :D

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

Posted: Sun Sep 03, 2017 8:43 pm
by snasui
:D ตัวอย่าง 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

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

Posted: Sun Sep 03, 2017 8:57 pm
by parakorn
ขอบพระคุณครับอาจารย์ :D

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

Posted: Mon Sep 11, 2017 12:44 am
by 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
ซึ่งยังไม่ได้ผลตามต้องการครับ จึงขอรบกวนด้วยครับ :flw:

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

Posted: Mon Sep 11, 2017 4:34 pm
by snasui
:D ตัวอย่างการปรับ 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

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

Posted: Tue Sep 12, 2017 9:20 am
by parakorn
snasui wrote::D ตัวอย่างการปรับ 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
ขอบคุณมากครับ :shock: :shock: :shock:

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

Posted: Tue Sep 12, 2017 3:58 pm
by 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

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

Posted: Tue Sep 12, 2017 8:59 pm
by snasui
:D การตรวจสอบว่าซ้ำ ตรวจสอบชื่อไฟล์หรือตรวจสอบข้อมูลครับ :?:

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

Posted: Wed Sep 13, 2017 12:45 am
by parakorn
ตรวจชื่อไฟล์ครับ(เข้าใจว่าต้อง นำมา match กับชื่อไฟล์ที่คีย์แล้วคือ column C)

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

Posted: Wed Sep 13, 2017 5:23 am
by snasui
:D ตัวอย่าง 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

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

Posted: Wed Sep 13, 2017 11:31 am
by parakorn
ลองปรับแล้ว ยังสามารถ Import ไฟล์เดิมได้ครับผม :tt:

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

Posted: Wed Sep 13, 2017 6:20 pm
by snasui
:D ปรับบรรทัด If ที่ใช้เช็คชื่อไฟล์เป็นด้านล่างครับ

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

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

Posted: Thu Sep 14, 2017 9:44 am
by parakorn
snasui wrote::D ปรับบรรทัด If ที่ใช้เช็คชื่อไฟล์เป็นด้านล่างครับ

If Application.CountIf(.Range("c:c"), VBA.Left(nb.Name, InStrRev(nb.Name, ".") - 1)) Then
Complete แล้วครับ :cp:

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

Posted: Sat Sep 16, 2017 5:12 pm
by parakorn
snasui wrote::D ตัวอย่าง 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 ต่อไปในลักษณะเดิมครับ :D

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

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

Posted: Sat Sep 16, 2017 7:15 pm
by snasui
:D แนบไฟล์โปรแกรมล่าสุดมาด้วยจะได้เขียนต่อไปจากนั้นครับ

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

Posted: Sat Sep 16, 2017 8:59 pm
by parakorn
ไฟล์แนบครับ :D

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

Posted: Sat Sep 16, 2017 11:43 pm
by snasui
parakorn wrote:ต้องการ นำข้อมูลชีทที่ชื่อไฟล์ ไม่ได้ต่อท้ายด้วย A (คือ B,C,D,E เรียงตามลำดับ) Copy มาวางที่ ไฟล์ที่มีชื่อต่อท้ายด้วย A แล้วให้ทำการ เปลี่ยนชื่อชีทแลพ ชื่อไฟล์ โดยลบ _A ออกไป(รวมถึงชื่อไฟล์ด้วยครับ) แล้วเซพ
:D อ่านแล้วยังไม่กระจ่างครับ เนื่องจากไม่พบไฟล์ที่ไม่มีต่อท้ายด้วยอักขระ A, B ไฟล์ที่ Zip มามี 4 ไฟล์คือ incentive_A.txt, incentive2_A.txt, incentive_ฺB.txt และ incentive2_B.txt

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

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

Posted: Thu Sep 21, 2017 10:09 am
by parakorn
แนบไฟล์มาใหม่ครับผม :D

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
All times are UTC+07:00
Page 1 of 2

Powered by phpBB® Forum Software © phpBB Limited