การรันคำสั่งแบบวนLoop

[sakajohn]

รบกวนสอบถามครับ ผมต้องการให้ นำข้อมูลในไฟล์ รับจ่ายAPP ตั้งแต่ cell A3 ถึง F3 ไปบันทึกใน ไฟล์ APPTPTAL โดย ทำต่อไปเรื่อยๆ จาก A3 ไป A4,A5 จนกว่าจะไม่มีข้อมูล ก็ให้จบการทำงาน ผมเขียนcode แบบนี้ครับ คือให้ค้นหา Cell A ถ้าไม่มีข้อมูลก็ให้ จบการทำงาน แต่ต้องเขียนคำสั่งเยอะมากครับ

Code: Select all

Sub พิมพ์ใบรับจ่ายAPP()
Application.ScreenUpdating = False

Set rg = Range("R1")
rg.Activate
If Application.CountA(Range("H1")) = 0 Then
   MsgBox "ใส่ผู้จัดทำด้วยครับ", vbCritical
   Exit Sub
End If
rg.Activate
If Application.CountA(Range("F3")) = 0 Then
    MsgBox "ใส่ สาเหตุ ด้วยครับ", vbCritical
    Exit Sub
End If


Dim x As Integer
    x = MsgBox("ตรวจสอบข้อมูลแล้ว ใช่หรือไม่", vbOKCancel)
    If x = vbCancel Then
        Sheets("Sheet1").Select
   Else

Application.Calculation = xlCalculationManual
ActiveSheet.Unprotect Password:="1234"
    'print
    ActiveSheet.PageSetup.PrintArea = "$A$1:$H$32"
   Application.ActivePrinter = "EPSON L360 Series on Ne03:"
    ActiveWindow.SelectedSheets.PrintOut Copies:=1, ActivePrinter:= _
          "EPSON L360 Series on Ne03:", Collate:=True, IgnorePrintAreas:=False
    
      'บันทึก AppTotal
      If Range("A3") = "" Then
      Else
     Application.Goto Reference:="OFFSET(R3C1,0,0,1,6)"
    Selection.Copy
    Workbooks("AppTotal.xlsx").Activate
    Sheets("Sheet1").Select
    Application.Goto Reference:="OFFSET(R1C1,COUNTA(C1),0)"
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
   End If
   ThisWorkbook.Activate
   If Range("A4") = "" Then
      Else
     Application.Goto Reference:="OFFSET(R3C1,0,0,1,6)"
    Selection.Copy
    Workbooks("AppTotal.xlsx").Activate
    Sheets("Sheet1").Select
    Application.Goto Reference:="OFFSET(R1C1,COUNTA(C1),0)"
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
   End If
    Range("A3:A32,F3:F32,H1").Select
    Selection.ClearContents
    Range("A3").Select
    ActiveSheet.Protect Password:="1234"
    Application.Calculation = xlCalculationAutomatic
    ThisWorkbook.Activate
   
   End If
End Sub

ผมต้องการให้ code มันทำแบบวน loop เองโดยถ้าเจอว่า Cell A ไม่มีค่าก็ให้จบการทำงานครับ จะต้องปรับ Codeอย่างไรครับ

[snasui]

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

Code: Select all

Sub พิมพ์ใบรับจ่ายAPP()
    Application.ScreenUpdating = False
    
    Set rg = Range("R1")
    rg.Activate
    If Application.CountA(Range("H1")) = 0 Then
        MsgBox "ใส่ผู้จัดทำด้วยครับ", vbCritical
        Exit Sub
    End If
    rg.Activate
    If Application.CountA(Range("F3")) = 0 Then
        MsgBox "ใส่ สาเหตุ ด้วยครับ", vbCritical
        Exit Sub
    End If
    
    
    Dim x As Integer
    x = MsgBox("ตรวจสอบข้อมูลแล้ว ใช่หรือไม่", vbOKCancel)
    If x = vbCancel Then
        Sheets("Sheet1").Select
    Else
    
    Application.Calculation = xlCalculationManual
    ActiveSheet.Unprotect Password:="1234"
    'print
    ActiveSheet.PageSetup.PrintArea = "$A$1:$H$32"
    Application.ActivePrinter = "EPSON L360 Series on Ne03:"
    ActiveWindow.SelectedSheets.PrintOut Copies:=1, ActivePrinter:= _
    "EPSON L360 Series on Ne03:", Collate:=True, IgnorePrintAreas:=False
    
    'บันทึก AppTotal
    If Range("A3") = "" Then
    Else
        With Worksheets("Sheet1")
            .Range("a3", .Range("a" & .Rows.Count).End(xlUp)).Resize(, 6).Copy
        End With
        With Workbooks("AppTotal.xlsx").Worksheets("Sheet1")
            .Range("a" & .Rows.Count).End(xlUp).Offset(1, 0) _
                .PasteSpecial xlPasteValues
        End With
'        Application.Goto Reference:="OFFSET(R3C1,0,0,1,6)"
'        Selection.Copy
'        Workbooks("AppTotal.xlsx").Activate
'        Sheets("Sheet1").Select
'        Application.Goto Reference:="OFFSET(R1C1,COUNTA(C1),0)"
'        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
'            :=False, Transpose:=False
        Application.CutCopyMode = False
'    End If
'    ThisWorkbook.Activate
'    If Range("A4") = "" Then
'    Else
'        Application.Goto Reference:="OFFSET(R3C1,0,0,1,6)"
'        Selection.Copy
'        Workbooks("AppTotal.xlsx").Activate
'        Sheets("Sheet1").Select
'        Application.Goto Reference:="OFFSET(R1C1,COUNTA(C1),0)"
'        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
'            :=False, Transpose:=False
'        Application.CutCopyMode = False
'    End If
    Range("A3:A32,F3:F32,H1").Select
    Selection.ClearContents
    Range("A3").Select
    ActiveSheet.Protect Password:="1234"
    Application.Calculation = xlCalculationAutomatic
    ThisWorkbook.Activate
    End If
End Sub

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

[sakajohn]

ขอบคุณครับอาจารย์ ครั้งต่อไปผมจะแนบไฟล์มาทั้งหมดครับ