วิธีการดึงข้อมูลจากที่เลือก เพื่อ copy ไปอีก Sheet หนึ่ง

[titti]

รบกวนทุกท่านครับ ผมมีเรื่องสอบถาม

คือ ผมต้องการเขียน Code VBA โดยมีทั้งหมด 3 sheet คือ sheet ที่ 1 เป็นเพียงแค่ชื่อ เพื่อใช้ในการเลือกว่าจะเอาค่าใดบ้าง โดยจะเลือกได้ไม่เกินกว่า 5 ค่า ตามตารางใน Sheet ที่ 3

ส่วน Sheet ที่ 2 คือ ฐานข้อมูลของ Sheet ที่ 1 โดยภายหลังจากมีการเลือกค่าใน Sheet ที่ 1 แล้วรายละเอียดอื่นๆ จะถูกย้ายไปยัง Sheet ที่ 3

ส่วน Sheet ที่ 3 คือ Sheet ที่จะแสดงถึงค่าทั้งหมด ภายหลังจากการเลือกข้อมูลใน Sheet ที่ 1 แล้ว รวมถึงรายละเอียดต่างๆ

ไม่ทราบว่าทุกท่านพอจะมีแนวทางในการเขียน Code VBA ด้วยวิธีใดบ้างครับ ขอบคุณมากครับ

[bank9597]

ลองบันทึกมาโครมาดูก่อนครับ ติดตรงไหนจะช่วยปรับให้ครับ พอดีว่าฟอรั่มมีกฏครับ

[titti]

ขอโทษด้วยครับ

ผมลอง Record Marco มาแล้ว แต่จะใส่ว่า (IF) เพื่อที่จะเลือกค่าใดที่เป็น True และการเลือกค่าใน Sheet 1 ให้ตรงกับค่า Sheet 2 ไม่ได้ครับ

Sub Macro1()
'
' Macro1 Macro
'

'
Sheets("Sheet1").Select
Sheets("Sheet2").Select
Range("B3:E3,B6:E6,B8:E8").Select
Range("B8").Activate
Selection.Copy
Sheets("Sheet3").Select
Range("B3").Select
ActiveSheet.Paste
Range("B3").Select
End Sub

ขอรบกวนด้วยครับ

[snasui]

ให้แนบ Code มาในไฟล์แล้วแนบไฟล์นั้นมาใหม่ครับ

สำหรับการโพสต์ Code ให้อ่านตามกฎข้อ 5 ด้านบนครับ

[titti]

ขอโทษอีกครั้งครับที่ผมไม่ได้อ่าน กฏ การใช้บอร์ดครับ

Code: Select all

Sub Macro1()
'
' Macro1 Macro
'

'
    Dim j, result, lastrow, a As Long
    j = Worksheets("Sheet2").Range("G3").Value
    lastrow = Worksheets("Sheet1").UsedRange.Rows.Count
    For Row = 3 To lastrow
        If j = True Then
            Sheets("Sheet2").Select
            result = Sheets("Sheet2").Range("B" & Row).Copy
            Sheets("Sheet3").Select
            a = Sheets("Sheet3").Range("B" & Row).PasteSpecial
        End If
             Row = Row + 1
    Next
End Sub

[snasui]

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

Code: Select all

Sub test()
    Dim rAll As Range, r As Range
    With Sheets("Sheet2")
        Set rAll = .Range("g3", .Range("g" & .Rows.Count).End(xlUp))
    End With
    Sheets("Sheet3").Range("b3:e1000").ClearContents
    For Each r In rAll
        If r.Value = True Then
            With Sheets("Sheet3")
                If .Range("b3").Value = "" Then
                    .Range("b3").Value = r.Offset(0, -5).Value
                Else
                    .Range("b" & .Rows.Count).End(xlUp).Offset(1, 0).Value = r.Offset(0, -5).Value
                End If
            End With
        End If
    Next r
End Sub

[bank9597]

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

Code: Select all

Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Dim ws3 As Worksheet
    Dim rRange As Range
    Dim nRange As Range
    Dim lRange As Range
    Dim nlRange As Range
    Dim tRange As Range
    Dim ntRange As Range
    Dim lngws1LastRow As Long
    Dim lngws2LastRow As Long
    Dim lngws3LastRow As Long
    
    Set ws1 = Sheets("Sheet1")
    Set ws2 = Sheets("Sheet2")
    Set ws3 = Sheets("Sheet3")
    
    lngws1LastRow = ws1.Range("G" & ws1.Rows.Count).End(xlUp).Row
    lngws2LastRow = ws2.Range("B" & ws2.Rows.Count).End(xlUp).Row
    
    Set rRange = ws1.Range("G3:G" & lngws1LastRow)
    Set lRange = ws2.Range("B3:B" & lngws2LastRow)
    Set tRange = ws3.Range("B3:E100")
    
    tRange.ClearContents

    For Each nRange In rRange
        
        If nRange Then
            For Each nlRange In lRange
                If nlRange = nRange.Offset(0, -5) Then
                   nlRange.Offset(0, 0).Resize(1, 4).Copy
                   lngws3LastRow = ws3.Range("B" & ws3.Rows.Count).End(xlUp).Row
                   ws3.Range("B" & lngws3LastRow + 1).PasteSpecial xlPasteValues
                End If
            Next nlRange
        End If
    Next nRange

[titti]

ขอบคุณ ท่าน snasui และ ท่าน bank9597 มากครับ