การระบุชื่อชีท กรณี Loop เพื่อนำเข้าข้อมูล

[Bafnet]

สวัสดีครับอาจารย์
วันนี้มีเรื่องรบกวนขอคำแนะนำการแก้ไข พยายามแล้วครับ
1.ต้องการนำเข้าข้อมูลจากไฟล์เอ็กเซลอืนที่มีหลายชีท
โดยทำการ Loop ชีท เพื่อนำเข้าข้อมูลให้ครบทุกชีท
2.เมื่อเปิดไฟล์ ให้เช็คก่อนว่าไฟล์ที่เลือกมีกี่ชีทนำค่าไปเก็บไว้
3.Loop คำสั่ง ให้ r = ชีท 1 , 2 .... จนเท่ากับจำนวนชีทที่เก็บค่าไว้ จึงหยุดทำ
4.เกิดปัญหาที่ การกำหนดค่า r ซึ่งได้ลองทั้ง r AS long และ r As sting แต่เกิด Debug
ค่า r ยังไม่ถูกต้อง
มีคำสั่งที่ผมพยายามดังนี้

Code: Select all

Private Sub CommandButton2_Click()
Dim fileToOpen
Dim rs As Range
Dim ri As Range
Dim ro As Range
Dim rx As Range
Dim r As Long
Dim Mydata As Range
Dim MyFile As String
Dim sFile As String
Dim xFile As String
Dim FileSaveName As String
'On Error Resume Next
Application.ScreenUpdating = False

With Workbooks("FBI.xlsm").Worksheets("Rest")
Set rs = Workbooks("FBI.xlsm").Worksheets("Rest").Range("A1")
End With

With Workbooks("FBI.xlsm").Worksheets("FBI")
Set ri = Workbooks("FBI.xlsm").Worksheets("FBI").Range("A1")
End With
fileToOpen = Application.GetOpenFilename '( _
      FileFilter:="WorkbookMacro (*.xls),*.xls")
      MyFile = fileToOpen

 If fileToOpen = False Then
  MsgBox "โปรดเลือกไฟล์ครับ"CIM 360"
 Exit Sub
 End If
 
 
  If fileToOpen <> False Then
Workbooks.OpenText Filename:=MyFile
  Application.DisplayAlerts = False
   rs.Value = ActiveWorkbook.Worksheets.Count 'ส่งจำนวนชีทไฟล์ที่เลือกไปเก็บไว้
   
   r = 1
   Do Until r = rs.Value
   If r = 1 Then
   ActiveWorkbook.Worksheets(r).Columns("A11:S30").Select ' ตำแหน่งที่เกิดปัญหา
 Selection.Copy: ri.PasteSpecial xlPasteValues
   Application.CutCopyMode = False
    Else
  ActiveWorkbook.Worksheets(r).Columns("A3:Q23").Select
 Selection.Copy: ri.PasteSpecial xlPasteValues
   Application.CutCopyMode = False
   End If
   With Workbooks("FBI.xlsm").Worksheets("FBI")
Set ro = .Range(.Range("A1"), .Range("S40") _
    .End(xlUp)).SpecialCells(xlCellTypeVisible)
  End With
  With Workbooks("FBI.xlsm").Worksheets("FBIX")
Set rx = Workbooks("FBI.xlsm").Worksheets("FBIX").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
End With
 ro.Select
 ro.Copy: rx.PasteSpecial xlPasteValues
  Application.CutCopyMode = False
  
   r = r + 1
     DoEvents
Loop
   
 ActiveWorkbook.Close True

 End If
 
End Sub

ไฟล์งาน= FBI
ไฟล์ข้อมูลที่ต้องการนำเข้า= ปาลัส
รบกวนขอคำแนะนำด้วยครับด้วยครับ

[snasui]

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

Code: Select all

'Other code
If r = 1 Then
    ActiveWorkbook.Worksheets(r).Select
    Range("A11:S30").Copy
    ri.PasteSpecial xlPasteValues
    Application.CutCopyMode = False
Else
    ActiveWorkbook.Worksheets(r).Select
    Range("A3:Q23").Copy
    ri.PasteSpecial xlPasteValues
   Application.CutCopyMode = False
End If
'Other code

[Bafnet]

อาจารย์ครับได้ปรับเปลี่ยนตามคำแนะนำ
อาการ Debug ไม่ปรากฏว่า ไม่มีข้อมูลใดๆมาทั้งสิ้น
ได้ทดสอบไล่คำสั่งดูพบว่ามันดันไป Copy ที่ชีท 1 ของไฟล์ FBI ที่ชื่อ Rest
และ Copy เฉพาะ A3:Q23
ช่วยด้วยครับ ไม่ว่าจะลองปรับเปลี่ยนโดนระบุเป็นชื่อเวิร์คบุ๊คโดยตรง ก็ยังทำไม่สำเร็จ
กลายเป็นตัวมัน Copy ชีท1 ตัวมันเอง ไม่ยอม copy ไฟล์ปาลัส

Code: Select all

Private Sub CommandButton2_Click()
Dim fileToOpen
Dim rs As Range
Dim ri As Range
Dim ro As Range
Dim rx As Range
Dim r As Long
Dim x As String
Dim Mydata As Range
Dim MyFile As String
Dim sFile As String
Dim xFile As String
Dim FileSaveName As String
'On Error Resume Next
Application.ScreenUpdating = False
With Workbooks("FBI.xlsm").Worksheets("Rest")
Set rs = Workbooks("FBI.xlsm").Worksheets("Rest").Range("A1")
End With
With Workbooks("FBI.xlsm").Worksheets("FBI")
Set ri = Workbooks("FBI.xlsm").Worksheets("FBI").Range("A1")
End With

fileToOpen = Application.GetOpenFilename '( _
      FileFilter:="WorkbookMacro (*.xls),*.xls")
      MyFile = fileToOpen
 If fileToOpen = False Then
  MsgBox "โปรดเลือกไฟล์", vbOKOnly, "CIM 360"
 Exit Sub
 End If
 
 
  If fileToOpen <> False Then
Workbooks.OpenText Filename:=MyFile
  Application.DisplayAlerts = False
   rs.Value = ActiveWorkbook.Worksheets.Count
      r = 1
      Do Until r = rs.Value
 If r = 1 Then
    ActiveWorkbook.Worksheets(r).Select
    Range("E11:S30").Copy
    ri.PasteSpecial xlPasteValues
    'Application.CutCopyMode = False
Else
    ActiveWorkbook.Worksheets(r).Select
    Range("A3:Q23").Copy
    ri.PasteSpecial xlPasteValues
   'Application.CutCopyMode = False
End If
   With Workbooks("FBI.xlsm").Worksheets("FBI")
Set ro = .Range(.Range("A1"), .Range("S20") _
    .End(xlUp)).SpecialCells(xlCellTypeVisible)
  End With
  With Workbooks("FBI.xlsm").Worksheets("FBIX")
Set rx = Workbooks("FBI.xlsm").Worksheets("FBIX").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
End With
' ro.Select
 'ro.Copy: rx.PasteSpecial xlPasteValues
  'Application.CutCopyMode = False
    r = r + 1
    DoEvents
Loop
   
 ActiveWorkbook.Close True
 
 End If
 
End Sub

อาจารย์ช่วยด้วยครับ

[snasui]

กรณีมีการ Copy ข้าม Workbook ควรระบุให้ชัดว่าต้องการ Copy จาก Workbook ใด ไป Workbook ใด

Code ที่ผมปรับไปให้เพราะใช้คำว่า ActiveWorkbook ซึ่งคำว่า ActiveWorkbook คือไฟล์ปัจจุบันที่กำลังทำงาน หากระบุได้ว่าเป็นไฟล์ใดหรือเป็นไฟล์จากตัวแปรใดก็ให้ใช้ตามนั้น จะได้ไม่สับสน

จากด้านบน คำว่า ActiveWorkbook ที่เขียนใน Code ต้องการให้เป็นไฟล์ใด นอกจากนี้ควรลำดับสิ่งที่ต้องการจะทำและยกตัวอย่างผลลัพธ์ที่ต้องการมาด้วยจะได้เข้าใจตรงกันครับ