วิธีดึงไฟล์ TEXT แบบ auto ด้วย VBA

[Jazmin]

โค้ดที่ใช้อยู่มันต้องเปลี่ยนชื่อไฟล์ text ที่เก็บไว้ ใน ไดร์ฟ E ให้เป็นชื่อเดียวกัน
แบบนี้ค่ะ
1(1)
1(2)
1(3)
ถึงจะดึงมาได้ค่ะ อยากทราบว่าต้องแก้โค้ดจุดไหนบ้างคะ ที่ให้ดึงข้อมูลมาโดยไม่ต้องเปลี่ยนชื่อไฟล์ค่ะ แล้วให้ดึงข้อมูลมาตลอดจนครบไฟล์ที่อยู่ในไดร์ฟค่ะ

Code: Select all

Dim i As Integer


Private Sub CommandButton2_Click()
 Dim row As Integer
row = 10
      Do While Range("c" & row).Value <> ""
         row = row + 1
         Loop
     Range("b10:z" & row).Clear
     i = 0
    
End Sub

Private Sub CommandButton3_Click()
Dim r As Integer

r = 10
      Do While Range("c" & r).Value <> ""
         r = r + 1
         Loop
     Range("AA10:ap" & r).Clear
i = 10
      Do While Range("c" & r).Value <> ""
         i = i + 1
         Loop
     Range("AA10:ap" & r).Clear

   
  
   '%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%TOY%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
    'Create the input strings.
Dim DataLine As String
Dim ThisCell As String

' Used for looping.
Dim Counter As Integer
Counter = 1
Dim CellCounter As Integer
Dim col As Integer

For col = 1 To i

''For col = 1 To Range("F3").Value

 ' Open the file.
 Open "E:\1 (" & col & ").txt" For Input As #1
Counter = 1
' Read the data one line at a time.
While Not EOF(1)
Line Input #1, DataLine
' Place the data in the worksheet.
Sheet7.Cells(Counter, 1) = DataLine


' Update the counter.
Counter = Counter + 1
Wend

' Close the file.
Close #1

   '%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%End TOY%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
        Dim row As Integer
        row = 10
        Do While Range("c" & row) <> ""
           row = row + 1
           
        Loop

        
        ''Range("b5").Value = row - 9
        'transpose
        Range("A1:A24").Copy
     
        Range("C" & row).PasteSpecial paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
          False, Transpose:=True
        ' Range("b" & row).Value = Now()
         
        'Cells.Select
        'Cells.EntireColumn.AutoFit
        Range("A1:A150").ClearContents
        


    Range("aa6:AP6").Copy
    Range("aa10:AP" & row).PasteSpecial xlPasteFormulas
    'Range("aa10:AO" & row).PasteSpecial xlPasteValues
    
   ' Application.CutCopyMode = False
    Columns("A:A").Delete Shift:=xlToLeft
    
    Columns("A:A").Insert Shift:=xlToRight
    ''Label6.Caption = Range("L3").Text
    ''Range("b6").Select
    
    Next col
End Sub

[snasui]

กรุณาแนบไฟล์ Excel ที่มี Code VBA มาด้วยจะได้สะดวกในการทดสอบของเพื่อนสมาชิกครับ

[Jazmin]

แนบไฟล์ค่ะ

[puriwutpokin]

แนบไฟล์ค่ะ

ไฟล์​ที่มีโค้ด ตามที่อาจารย์​แจ้ง ต้องมีนามสกุล,. XLS, XLSM, หรือ XLB

[Jazmin]

ขอโทษด้วยค่ะ นี่ค่ะ ไฟล์แนบ

[puriwutpokin]

ขอโทษด้วยค่ะ นี่ค่ะ ไฟล์แนบ

ลองปรับเป็น

Code: Select all

Sub Test()
  Dim LastDot As Long, Path As String, Filename As String, NewFilename As String
  On Error Resume Next
  Path = "E:\"
  Filename = Dir(Path & "*.txt")
  Do While Len(Filename)
 For i = 1 To 99
    LastDot = InStrRev(Filename, ".")
    NewFilename = Mid(Application.Substitute(Filename, ".", "1(" & i & ")."), 2, Len(Filename) + 3)
    Name Path & Filename As Path & NewFilename
    Filename = Dir()
    Next
  Loop
End Sub

[Jazmin]

ขอบคุณค่ะ จะลองนำไปประยุกต์ใช้ค่ะ