copy ข้อมูลแบบมีเงือนไขตาม cell ที่เลือก

[March201711]

ต้องการข้อมูลข้อมูลจาก sheet GGG_2023 ไปตามวันที่เลือกที่ cell F1 เช่น
เช่น เลือก cell F1 เป็นวันที่ 11/05/2023 ให้เลือกข้อมูลที่ตรงกับ colum G (hightlight สีเหลือง) ให้ copy ข้อมูลของวันที่ 11/05/2023 ทั้งหมดของแถวนั้น ทั้งบรรทัดมาวางไว้ที่ sheet GGG_0523
เช่น เลือก cell F1 เป็นวันที่ 28/04/2023 ให้เลือกข้อมูลที่ตรงกับ colum G (hightlight สีเขียว) ให้ copy ข้อมูลของวันที่ 28/04/2023 ทั้งหมดของแถวนั้น ทั้งบรรทัดมาวางไว้ที่ sheet GGG_0423
เช่น เลือก cell F1 เป็นวันที่ 09/03/2023 ให้เลือกข้อมูลที่ตรงกับ colum G (hightlight สีส้ม) ให้ copy ข้อมูลของวันที่ 09/03/2023 ทั้งหมดของแถวนั้น ทั้งบรรทัดมาวางไว้ที่ sheet GGG_0323

Code: Select all

Sub Update_month()
'
'
'''' May23  (sheet GGG_0523)
    
    Range("B112").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Selection.Copy
    Range("D120").Select
    Sheets("GGG_0523").Select
    Range("B15").Select
    ActiveSheet.Paste
    Range("Q17").Select
    
'''' April23  (sheet GGG_0423)
       Range("B7:R7").Select
    Selection.Copy
    Sheets("GGG_0423").Select
    Range("B6").Select
    ActiveSheet.Paste
    Range("R2").Select
    Sheets("GGG_2023").Select
    Range("Q3").Select
    
'''' Mar23  (sheet GGG_0323)
    Range("B8:F10").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range("B8:R10").Select
    Selection.Copy
    Sheets("GGG_0323").Select
    Range("B6").Select
    ActiveSheet.Paste
    Range("G13").Select
    Sheets("GGG_2023").Select
    Range("S3").Select
    Application.CutCopyMode = False
    Range("H3").Select
    
    
End Sub

[snasui]

ตัวอย่าง Code ในชีต GGG_2023 (ไม่ใช่ใน Module) ครับ

Code: Select all

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim rall As Range, r As Range
    Dim strSh As String
    If Target.Address = Me.Range("f1").Address Then
        With Worksheets("GGG_2023")
            Set rall = .Range("g7", .Range("g" & .Rows.Count).End(xlUp))
            For Each r In rall
                strSh = "GGG" & VBA.Format(r.Value, "_mmyy")
                If r.Value = Target.Value Then
                    With Worksheets(strSh)
                        .Range("b" & Rows.Count).End(xlUp).Offset(1, 0).Resize(1, 22).Value = _
                            r.Offset(0, -5).Resize(1, 22).Value
                    End With
                End If
            Next r
        End With
    End If
End Sub

[March201711]

ทำไมทำปุ่มให้กดรัน แล้ว ไม่สามารถ assign marco ได้คะ

[snasui]

Code ลักษณะนั้นไม่ได้ใช้งานผ่านการปุ่ม แค่เปลี่ยนค่าในเซลล์ F1 มันก็ทำงานแล้ว เป็นการใช้งานผ่าน Change Event ครับ

[March201711]

ค่ะ มีความซับซ้อนมากจังค่ะ ถ้าในข้อมูลไม่มีวันที่ที่ F1 เลือกอยากให้ขึ้น pop up แจ้งว่าไม่มีได้ไหมหรือปล่าวคะ

[snasui]

ทำได้ครับ ลองปรับ Code มาเองก่อน ติดตรงไหนค่อยถามกันต่อ สำหรับการตรวจสอบว่ามีหรือไม่มีใช้ฟังก์ชัน Countif มาช่วยได้ครับ

[March201711]

พอกดวันที่ 13/5/23 แล้ว มันก้อขึ้น pop up Finish ค่ะ

Code: Select all

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim rall As Range, r As Range
    Dim strSh As String
    If Target.Address = Me.Range("f1").Address Then
        With Worksheets("GGG_2023")
            Set rall = .Range("g7", .Range("g" & .Rows.Count).End(xlUp))
            For Each r In rall
                strSh = "GGG" & VBA.Format(r.Value, "_mmyy")
                If r.Value = Target.Value Then
                    With Worksheets(strSh)
                        .Range("b" & Rows.Count).End(xlUp).Offset(1, 0).Resize(1, 22).Value = _
                            r.Offset(0, -5).Resize(1, 22).Value
                    End With
                End If
            Next r
        End With
    End If
    
result = Application.WorksheetFunction.CountIf(Range("G7:G20"), "")
 
    MsgBox " Finished "
End Sub

[snasui]

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

Code: Select all

'Other code
With Worksheets("GGG_2023")
    Set rall = .Range("g7", .Range("g" & .Rows.Count).End(xlUp))
    If Application.WorksheetFunction.CountIf(rall, Target.Value) = 0 Then
        MsgBox "Not found", vbInformation
        Exit Sub
    End If
    For Each r In rall
'Other code