:D snasui.com ยินดีต้อนรับ :D
ยินดีต้อนรับสู่กระดานถามตอบ Excel and VBA และอื่น ๆ ที่เป็นมิตรกับทุกท่าน มีไฟล์แนบมหาศาล ช่วยให้ท่านค้นหาและติดตามศึกษาได้โดยง่าย :thup: สมาชิกท่านใดที่ยังไม่ได้ระบุ Version ของ Excel ที่ใช้งานจริง สามารถทำตาม Link นี้เพื่อจะได้รับคำตอบที่ตรงกับ Version ของท่านครับ :arrow: ระบุ Version ของ Excel
:!: โปรดทราบ :!:
  1. กรุณาอ่านกฎการใช้บอร์ด (Forum rules) ในตำแหน่งด้านบนของแต่ละบอร์ด
  2. การสมัครสมาชิก การ Login การกู้คืนรหัสผ่าน
    1. สมัครสมาชิกดูขั้นตอนได้ที่ :arrow: สมัครสมาชิก
    2. Login เข้าระบบโดยคลิกปุ่ม Login ตรงมุมขวาบนของหน้านี้ :roll:
    3. การ Login ผ่าน Facebook ดูวิธีที่ :arrow: Login ผ่าน Facebook
    4. ลืมรหัสผ่านสามารถรับรหัสใหม่ได้ที่ :arrow: Reset รหัสผ่าน
  3. มีปัญหาการใช้งาน แจ้งผู้ดูแลระบบได้ที่ :arrow: ติดต่อผู้ดูแลระบบ
  4. กำหนดการตั้งค่าส่วนตัว เช่นตั้งค่าภาษาเป็นไทยหรืออังกฤษดูได้ที่ :arrow: ตั้งค่าส่วนตัว
  5. การตั้งและตอบกระทู้ดูได้ที่ :arrow: วิธีการตั้งและตอบกระทู้
  6. การจัดรูปแบบตัวอักษรด้วย bbcode ในช่องแสดงความคิดเห็นดูได้ที่ :arrow: จัดรูปแบบตัวอักษร
  7. กำหนดขนาดตัวอักษรใน Browser ดูได้ที่ :arrow: กำหนดขนาดตัวอักษรใน Browser

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

ฟอรัมถาม-ตอบปัญหาการใช้งาน MS Excel and VBA
Forum rules
  1. ไม่อนุญาตให้ใช้ภาษาแชทในการถามและตอบปัญหา ไม่ใช้คำว่า "คับ" หรือ "อ่ะครับ" แทนคำว่า "ครับ" ไม่ใช้คำว่า "เด๋ว" แทนคำว่า "เดี๋ยว" เป็นต้น เนื่องจากเมื่อแปลเป็นภาษาต่างประเทศแล้วจะให้ความหมายผิดไปจากที่ควรจะเป็น
  2. ห้ามถามโดยระบุชื่อผู้ตอบและต้องตั้งชื่อกระทู้ให้สื่อถึงปัญหาที่จะถาม ไม่ตั้งชื่อว่า ช่วยด้วยครับ, มีปัญหามาปรึกษาครับ เป็นต้น
  3. กรุณาอธิบายปัญหาและระบุคำตอบที่ต้องการมาในกระทู้ด้วยเสมอถึงแม้จะอธิบายไว้ในไฟล์แนบแล้วก็ตาม ทั้งนี้เพื่ออำนวยความสะดวกแก่เพื่อนสมาชิกในการค้นหาข้อมูล
  4. กรุณาแนบไฟล์ตัวอย่างพร้อมแสดงคำตอบที่ถูกต้องมาในไฟล์ด้วยเพื่อให้ง่ายต่อการทำความเข้าใจและสะดวกต่อการตอบคำถาม (ขนาดไฟล์ไม่เกิน 500Kb ขนาดภาพไม่เกิน 800*600 Pixel) ไม่แนบเป็น Link มาจากแหล่งอื่นที่อาจจะถูกลบทิ้งไปโดยต้นทางในภายหลัง นอกจากนี้ไม่ควรแนบไฟล์ที่มีข้อมูลสำคัญอันก่อให้เกิดความเสียหายกับตนเองและผู้อื่น
  5. กรณีเป็นคำถามเกี่ยวกับ Programming เช่น VBA, VB.Net, C#, SQL ฯลฯ ต้องลองเขียนมาเองก่อนเสมอ ถามเฉพาะที่ติดปัญหา ระบุ Module, Procedure ที่ติดปัญหาให้ชัดเจน กรุณาโพสต์ Code ให้แสดงเป็น Code คือเปิดด้วย [code] และปิดด้วย [/code] ตัวอย่างเช่น [code]dim r as range[/code] เพื่อให้แตกต่างจากข้อความทั่วไป สะดวกในการอ่านและทดสอบ (คลิกเพื่อดูตัวอย่าง)
  6. กรุณาแจ้งผลการใช้งานเมื่อได้รับคำตอบว่าตรงกับความต้องการหรือไม่
User avatar
parakorn
Gold
Gold
Posts: 1223
Joined: Thu Mar 14, 2013 9:41 am
Location: Central Chaengwattana[Tops]
Excel Ver: 365
Contact:

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

#1

Post 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
You do not have the required permissions to view the files attached to this post.
User avatar
snasui
Site Admin
Site Admin
Posts: 30735
Joined: Sun Jan 24, 2010 12:33 pm
Location: Songkhla, Thailand
Excel Ver: 2010, 365
Contact:

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

#2

Post by snasui »

:D ลองแนบตัวอย่างไฟล์และไฟล์ Excel มาด้วยจะได้สะดวกในการทดสอบครับ
User avatar
parakorn
Gold
Gold
Posts: 1223
Joined: Thu Mar 14, 2013 9:41 am
Location: Central Chaengwattana[Tops]
Excel Ver: 365
Contact:

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

#3

Post by parakorn »

เพิ่มเติมไฟล์แนบครับ :D
You do not have the required permissions to view the files attached to this post.
User avatar
snasui
Site Admin
Site Admin
Posts: 30735
Joined: Sun Jan 24, 2010 12:33 pm
Location: Songkhla, Thailand
Excel Ver: 2010, 365
Contact:

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

#4

Post 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
User avatar
parakorn
Gold
Gold
Posts: 1223
Joined: Thu Mar 14, 2013 9:41 am
Location: Central Chaengwattana[Tops]
Excel Ver: 365
Contact:

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

#5

Post by parakorn »

ขอบพระคุณครับอาจารย์ :D
User avatar
parakorn
Gold
Gold
Posts: 1223
Joined: Thu Mar 14, 2013 9:41 am
Location: Central Chaengwattana[Tops]
Excel Ver: 365
Contact:

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

#6

Post 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:
You do not have the required permissions to view the files attached to this post.
User avatar
snasui
Site Admin
Site Admin
Posts: 30735
Joined: Sun Jan 24, 2010 12:33 pm
Location: Songkhla, Thailand
Excel Ver: 2010, 365
Contact:

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

#7

Post 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
User avatar
parakorn
Gold
Gold
Posts: 1223
Joined: Thu Mar 14, 2013 9:41 am
Location: Central Chaengwattana[Tops]
Excel Ver: 365
Contact:

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

#8

Post 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:
User avatar
parakorn
Gold
Gold
Posts: 1223
Joined: Thu Mar 14, 2013 9:41 am
Location: Central Chaengwattana[Tops]
Excel Ver: 365
Contact:

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

#9

Post 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
You do not have the required permissions to view the files attached to this post.
User avatar
snasui
Site Admin
Site Admin
Posts: 30735
Joined: Sun Jan 24, 2010 12:33 pm
Location: Songkhla, Thailand
Excel Ver: 2010, 365
Contact:

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

#10

Post by snasui »

:D การตรวจสอบว่าซ้ำ ตรวจสอบชื่อไฟล์หรือตรวจสอบข้อมูลครับ :?:
User avatar
parakorn
Gold
Gold
Posts: 1223
Joined: Thu Mar 14, 2013 9:41 am
Location: Central Chaengwattana[Tops]
Excel Ver: 365
Contact:

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

#11

Post by parakorn »

ตรวจชื่อไฟล์ครับ(เข้าใจว่าต้อง นำมา match กับชื่อไฟล์ที่คีย์แล้วคือ column C)
User avatar
snasui
Site Admin
Site Admin
Posts: 30735
Joined: Sun Jan 24, 2010 12:33 pm
Location: Songkhla, Thailand
Excel Ver: 2010, 365
Contact:

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

#12

Post 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
User avatar
parakorn
Gold
Gold
Posts: 1223
Joined: Thu Mar 14, 2013 9:41 am
Location: Central Chaengwattana[Tops]
Excel Ver: 365
Contact:

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

#13

Post by parakorn »

ลองปรับแล้ว ยังสามารถ Import ไฟล์เดิมได้ครับผม :tt:
You do not have the required permissions to view the files attached to this post.
User avatar
snasui
Site Admin
Site Admin
Posts: 30735
Joined: Sun Jan 24, 2010 12:33 pm
Location: Songkhla, Thailand
Excel Ver: 2010, 365
Contact:

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

#14

Post by snasui »

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

If Application.CountIf(.Range("c:c"), VBA.Left(nb.Name, InStrRev(nb.Name, ".") - 1)) Then
User avatar
parakorn
Gold
Gold
Posts: 1223
Joined: Thu Mar 14, 2013 9:41 am
Location: Central Chaengwattana[Tops]
Excel Ver: 365
Contact:

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

#15

Post by parakorn »

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

If Application.CountIf(.Range("c:c"), VBA.Left(nb.Name, InStrRev(nb.Name, ".") - 1)) Then
Complete แล้วครับ :cp:
User avatar
parakorn
Gold
Gold
Posts: 1223
Joined: Thu Mar 14, 2013 9:41 am
Location: Central Chaengwattana[Tops]
Excel Ver: 365
Contact:

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

#16

Post 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
You do not have the required permissions to view the files attached to this post.
User avatar
snasui
Site Admin
Site Admin
Posts: 30735
Joined: Sun Jan 24, 2010 12:33 pm
Location: Songkhla, Thailand
Excel Ver: 2010, 365
Contact:

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

#17

Post by snasui »

:D แนบไฟล์โปรแกรมล่าสุดมาด้วยจะได้เขียนต่อไปจากนั้นครับ
User avatar
parakorn
Gold
Gold
Posts: 1223
Joined: Thu Mar 14, 2013 9:41 am
Location: Central Chaengwattana[Tops]
Excel Ver: 365
Contact:

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

#18

Post by parakorn »

ไฟล์แนบครับ :D
You do not have the required permissions to view the files attached to this post.
User avatar
snasui
Site Admin
Site Admin
Posts: 30735
Joined: Sun Jan 24, 2010 12:33 pm
Location: Songkhla, Thailand
Excel Ver: 2010, 365
Contact:

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

#19

Post 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

จากไฟล์ดังกล่าว ช่วยลำดับการทำงานมาอีกครั้งเพื่อจะได้เข้าใจตรงกันครับ
User avatar
parakorn
Gold
Gold
Posts: 1223
Joined: Thu Mar 14, 2013 9:41 am
Location: Central Chaengwattana[Tops]
Excel Ver: 365
Contact:

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

#20

Post 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
You do not have the required permissions to view the files attached to this post.
Post Reply