Snasui Excel Forum

ได้แล้วขอบคุณมากนะคะ

:D ลองแนบไฟล์ที่มี Code มาด้วยจะได้ช่วยดูให้ได้ครับ

สำหรับการโพสต์ Code ให้อ่านกฎการใช้บอร์ดข้อ 5 ด้านบน จะมี Link แนะนำวิธีการโพสต์ให้แสดงเป็น Code จะได้สะดวกในการอ่านและคัดลอกไปใช้ครับ :roll:

ลองทำ Code ดูแล้วแต่ยังติดปัญหาตรงที่ไม่สามารถแก้ไขชื่อไฟล์ให้เป็นแบบเดียวกับตอนเลือก Folder ค่ะ

โค้ดจะเป็นการกดปุ่ม 2 ปุ่ม
- ปุ่มแรก Sub Test() ให้ทำการเลือก Folder ที่อยู่ไฟล์ทั้งหมด
- ปุ่มสอง addsheet_Link_BR() จะเป็นการทำการเพิ่ม copy sheet แล้วดึงข้อมูลจากไฟล์ที่เราเลือกที่อยู่ นำมาใส่ไฟล์ ปิด แล้วทำการ copy ใหม่จนกว่าจะหมด

ลองเปลี่ยนจาก MyDir = "C:\Users\VIVICHAN\Documents\work\2017\S2\BUDGET 2017\"

MyDir = sItem
MyDir = fldr
MyDir = Range("B1") & "\" อันนี้ลองทำเป็นวางข้อมูลไฟล์ไว้ที่ B1 ตอนแรกคิดว่าเป็นเพราะไม่มี "" กับ \ แต่ก็ไม่ได้อยู่ดี
MyDir = strPath

ก็ไม่ได้เลย ติดปัญหาที่ ChDir MyDir มันบอกว่าไม่มีที่อยู่ไฟล์ ทำยังไงได้บ้างคะ?
ขอบคุณมากค่ะ


Sub addsheet_Link_BR()
Dim i As Integer
Dim lastrow As Integer
Dim MyFile As String, Str As String, MyDir As String, Wb As Workbook
Dim Rws As Long, Rng As Range
Set Wb = ThisWorkbook
'change the address to suite

lastrow = Worksheets("Info").Cells(Worksheets("Info").Rows.Count, "A").End(xlUp).Row
For i = 1 To lastrow
Sheets("Form").Copy after:=Sheets(Sheets.Count)
ActiveSheet.Name = Worksheets("Info").Cells(i, 1).Value
[color=#FF0080] MyDir = "C:\Users\VIVICHAN\Documents\work\2017\S2\BUDGET 2017"[/color]
MyFile = Dir(MyDir & ActiveSheet.Name & "*_2017.xlsm") 'change file extension
ChDir MyDir
Application.ScreenUpdating = 0
Application.DisplayAlerts = 0

Do While MyFile <> ""
Workbooks.Open (MyFile)
With Worksheets("Rp-Cpx")
Sheets("Rp-Cpx").Select
Range("D1").Select
Range("D1:S146").Select
Application.CutCopyMode = False
Selection.Copy
Windows("ทดลอง3.xlsm").Activate
Range("D1").Select
Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Range("D1").Select
Windows(MyFile).Activate
ActiveWorkbook.Close True
End With
MyFile = Dir()

Loop
Next i

End Sub


Sub Test()
MsgBox GetFolder("C:\TEST_INITIAL\")
End Sub

Function GetFolder(strPath As String) As String
Dim fldr As FileDialog
Dim sItem As String
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
.Title = "Select a Folder"
.AllowMultiSelect = False
.InitialFileName = strPath
If .Show <> -1 Then GoTo NextCode
sItem = .SelectedItems(1)
End With
NextCode:

Range("B1").Value = fldr.SelectedItems(1)
GetFolder = sItem
Set fldr = Nothing

End Function