ขอCoce คำสั่งในการให้หาค่า ที่ตัวแปรเปลี่ยนไปเรื่อยๆ

[StartlearningVBA]

ขอบคุณค่ะ ที่ให้คำแนะนำ จะนำไปปรับปรุงในครั้งหน้า หรือครั้งต่อๆ ไป เนื่องจากเป็นมือใหม่
เลยยังไม่ทราบว่า ต้องเริ่มยังไงให้คนอื่นเค้าเข้าใจเราได้ง่ายๆ

[snasui]

ผมลองเขียน Code มาให้ตามด้านล่างพร้อมแนบไฟล์มาให้แล้ว ลองนำข้อมูลจริงมาวางใน File นี้แล้วคลิกปุ่ม Run สังเกตการเปลี่ยนแปลง สำหรับชีทที่ผมทำสีแดงไว้ไม่ได้ใช้งาน ลองปรับ Code ให้ตรงกับความต้องการใช้งานดูครับ

Code: Select all

Option Explicit

Sub SelectDataLessThanThree()
With Worksheets("data1")
    .Range("CC2:CC65536").ClearContents
    .Sort.SortFields.Add Key:=Range("N5:N50"), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    .Range("A5:V50").AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:= _
        .Range("CB1:CB2"), Unique:=False
    .Range("B5:B50").SpecialCells(xlCellTypeVisible).Copy
    .Range("CC1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    .ShowAllData
End With
    CodeFindBox
End Sub

Sub CodeFindBox()
Dim r As Range, rt As Range, rt1 As Range, rt2 As Range
Dim i As Integer
With Worksheets("data1")
    Set r = .Range(.Range("CC2"), .Range("CC65536").End(xlUp))
    Set rt2 = .Range("L6")
End With
Set rt1 = Worksheets("BoxList").Range("B65536").End(xlUp).Offset(1, 0)
For i = 1 To r.Count
    With Worksheets("TempQty")
            .Range("A1:J65536").ClearContents
    End With
    With Worksheets("box")
        .Range("AB3") = r(i)
        .Range("E1:M100").AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:= _
        .Range("AB1:AB2"), Unique:=False
        Set rt = .Range("M2:M100").SpecialCells(xlCellTypeVisible).Range("A1")
        Set rt1 = Worksheets("BoxList").Range("B65536").End(xlUp).Offset(1, 0)
        .Range("AC3") = rt: rt1 = rt
        .Range("E1:M100").AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:= _
        .Range("AC1:AC2"), Unique:=False
        .Range("A1:M100").SpecialCells(xlCellTypeVisible).Copy
            With Worksheets("TempQty")
                .Range("A1").PasteSpecial xlPasteValues
                .Range("M2:M46").Copy: rt2.PasteSpecial Paste:=xlPasteValues, Operation:=xlAdd
            End With
        .Range("A2:M100").SpecialCells(xlCellTypeVisible).ClearContents
        .ShowAllData
        End With
 Next
End Sub

Sub LoopProcedure()
Dim r As Range
Set r = Worksheets("data1").Range("CB3")
Do While r > 0
    SelectDataLessThanThree
Loop
End Sub

[StartlearningVBA]

ขอบคุณมากๆ เลยค่ะ เดี๋ยวจะลอง Run ดู แล้วจะรีบแจ้งผลค่ะ