การเรียกใช้ Call แล้ว Error และการ Copy เฉพาะข้อมูลที่ต้องการ VBA

[Polly]

สวัสดีค่ะ
เรียนสอบถามการแก้ไข การเรียกใช้ call แล้วพบ error และ การ copyเฉพาะข้อมูลที่ต้องการ รวม 2 ข้อค่ะ

1.การเรียกใช้ call เพื่อต้องการกดทีเดียวที่ sub one click() พบ error ที่ Module I_Import ชื่อ sub LoopThroughDirectory () แสดงค้างที่ ActiveSheet.Paste Destination:=Worksheets("Collect Data").Range(Cells(erow, 1), Cells(erow, 26)) แต่ถ้า run ทีละ sub สามารถใช้งานได้ปกติค่ะ

หากต้องการกดเรียกใช้งานทีเดียวที่ sub one click() มีวิธีแก้ไขไหมคะ

Code: Select all

Sub LoopThroughDirectory()
 Worksheets("Collect Data").Range("A3:Z100000").ClearContents
 
 Dim MyFile As String
 Dim erow
 Dim Filepath As String
 Filepath = "D:\Test\"
  MyFile = Dir(Filepath)
 Do While Len(MyFile) > 0
     If MyFile = "TODAY PREM MATCHING_Master_V2 - Test.xlsm" Then
     Exit Sub
     End If
     
     Workbooks.Open (Filepath & MyFile)
     Sheets(1).Name = "Daily Premium matching"
     Sheets("Daily Premium matching").Select
     Range("A2", ActiveCell.SpecialCells(xlLastCell)).Select
     Selection.Copy
     
     
     Windows("TODAY PREM MATCHING_Master_V2 - Test.xlsm").Activate
     erow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
     ActiveSheet.Paste Destination:=Worksheets("Collect Data").Range(Cells(erow, 1), Cells(erow, 26))
     Windows(MyFile).Activate
     
     Application.DisplayAlerts = False
     ActiveWindow.Close
   
     MyFile = Dir
     'ThisWorkbook.Worksheets("sheet1").Cells.EntireColumn.AutoFit
    
     Cells.Select
    With Selection.Font
        .Name = "Calibri"
        .Size = 9
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .TintAndShade = 0
    End With
 Loop
 
 'ActiveSheet.Columns("BO").NumberFormat = "General"
 End Sub

2. 2. การกด copy คลุมเฉพาะที่มีข้อมูล

2.1 ที่ Module VII_AllCollect ชื่อ sub CollectBroker() หากใช้ Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select จะคลุมไปถึง row ตำแหน่งล่าสุดที่เคยวางค่ะ และ copy แถวที่ว่างมาวางด้วย หากต้องการให้ copy เฉพาะข้อมูลถึงแถวที่มีข้อมูล เช่น หากมีข้อมูล A2:Q6 เอามาเฉพาะแค่นี้ค่ะ ไม่อยากใช้ Application.Goto Reference ค่ะ

2.2 โดยปกติข้อมูลจะเริ่มที่ A2ค่ะ หากไม่มีข้อมูลจะก๊อบปี้ จะเกิด bug ด้วยค่ะ แก้จุดนี้อย่างไรหรือคะ

ไฟล์ต.ย. ชื่อ Import1 และ Import2
ใช้ MS.Office 365ค่ะ ขอบคุณค่ะ

Code: Select all

Sub CollectBroker()
Sheets("Broker").Activate
Range("A2").Select

Application.CommandBars("Office Clipboard").Visible = False

'Application.Goto Reference:="Broker_Collect"

'Range(Range("A2"), Range("A2").End(xlDown)).Select
'Range(Range("A2"), Range("A2").End(xlToRight)).Select
'Range("A2").Select
Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
'Application.CutCopyMode = False
    
Selection.Copy

Sheets("AllCollect-Broker").Select
    Range("A2").Select
    Selection.End(xlDown).Select
    ActiveCell.Offset(1, 0).Range("A1").Select
    ActiveSheet.Paste
    
Sheets("Broker").Select
Range("A2").Select
Application.CutCopyMode = False
    
End Sub

[snasui]

1.การเรียกใช้ call เพื่อต้องการกดทีเดียวที่ sub one click() พบ error ที่ Module I_Import ชื่อ sub LoopThroughDirectory () แสดงค้างที่ ActiveSheet.Paste Destination:=Worksheets("Collect Data").Range(Cells(erow, 1), Cells(erow, 26)) แต่ถ้า run ทีละ sub สามารถใช้งานได้ปกติค่ะ

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

Code: Select all

'Other code
Selection.Copy
     
     Windows("TODAY PREM MATCHING_Master_V2 - Test.xlsm").Activate
     erow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
     Worksheets("Collect Data").Activate
     ActiveSheet.Paste Destination:=Worksheets("Collect Data").Range(Cells(erow, 1), Cells(erow, 26))
     Application.CutCopyMode = False
     Windows(MyFile).Activate
     
     Application.DisplayAlerts = False
     'Other code

2. 2. การกด copy คลุมเฉพาะที่มีข้อมูล

2.1 ที่ Module VII_AllCollect ชื่อ sub CollectBroker() หากใช้ Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select จะคลุมไปถึง row ตำแหน่งล่าสุดที่เคยวางค่ะ และ copy แถวที่ว่างมาวางด้วย หากต้องการให้ copy เฉพาะข้อมูลถึงแถวที่มีข้อมูล เช่น หากมีข้อมูล A2:Q6 เอามาเฉพาะแค่นี้ค่ะ ไม่อยากใช้ Application.Goto Reference ค่ะ

2.2 โดยปกติข้อมูลจะเริ่มที่ A2ค่ะ หากไม่มีข้อมูลจะก๊อบปี้ จะเกิด bug ด้วยค่ะ แก้จุดนี้อย่างไรหรือคะ

ตัวอย่างการปรับ Code กรุณสังเกตการประกาศตัวแปร การใช้ With เข้ามาช่วยย่อ Code ให้เกิดความกระชับ

Code: Select all

Sub CollectBroker()
    Dim lstRw As Long
    Dim sc As Range
    Application.CommandBars("Office Clipboard").Visible = False
    
    With Sheets("Broker")
        If .Range("a2").Value = "" Then
            lstRw = 2
        Else
            lstRw = .Range("a" & .Rows.Count).End(xlUp).Row
        End If
        Set sc = .Range("a2:q" & lstRw)
    End With
    With Sheets("AllCollect-Broker")
        sc.Copy .Range("a" & .Rows.Count).End(xlUp).Offset(1, 0)
    End With
    Sheets("Broker").Select
    Range("A2").Select
    Application.CutCopyMode = False
End Sub

[Polly]

เรียน อาจารย์คะ

ใช้งานได้ตรงตามความต้องการค่ะ ขอบคุณมากค่ะ