สอบถามวิธีการคัดลอกข้อมูลจาก file หลัก ไปยัง file งานโดยแยกข้อมูลลงตาม sheet

[lumi]

ต้องการคัดลอกข้อมูลที่อยู่ใน file Data.xlsx ไปวางใน file Vendor.xlsx โดยแยกตาม vendor ไปวางในแต่ละ sheet
ตาม file ตัวอย่างมีวิธีใดบ้างคะที่จะสามารถให้ระบบทำให้โดยไม่ต้อง copy ไปวางเองทุก sheet เนื่องจากข้อมูลจริง
มีมากกว่า 3 รายค่ะ

[snasui]

งานลักษณะนั้นคงต้องพึ่งการเขียน VBA เข้าไปช่วย ซึ่งต้องเขียนมาเองก่อนตามกฎการใช้บอร์ดข้อ 5 ด้านบน ติดตรงไหนค่อยถามกันต่อครับ

[lumi]

ลองเขียนแล้วตามตัวอย่างที่แนบมา ตอนนี้ใช้วิธี copy sheet จาก file data มารวมไว้ที่ file vendor แล้วเขียน code
ดึงข้อมูลไปวาง (ต้องออกตัวก่อนนะคะไม่ค่อยเก่งเรื่อง vba แต่พอได้บ้าง) พอกดปุ่ม copy ข้อมูลไปวางที่ sheet แรก
sheet เดียว ไม่แน่ใจว่า code ผิดตรงไหนค่ะ

Code: Select all

Private Sub CmdCopy_Click()
Application.ScreenUpdating = False
r = 20
For k = 11 To 160
If Sheet1.Cells(k, 10) <> "" And Sheet1.Cells(k, 2) <> "**" And Sheet1.Cells(k, 10) <> "Amt in loc" Then
    If Sheet1.Cells(k, 13) = "1000001" Then
        Sheet2.Cells(r, 2) = Sheet1.Cells(k, 2)
        Sheet2.Cells(r, 3) = Sheet1.Cells(k, 3)
        Sheet2.Cells(r, 4) = Sheet1.Cells(k, 4)
        Sheet2.Cells(r, 5) = Sheet1.Cells(k, 5)
        Sheet2.Cells(r, 6) = Sheet1.Cells(k, 6)
        Sheet2.Cells(r, 7) = Sheet1.Cells(k, 7)
        Sheet2.Cells(r, 8) = Sheet1.Cells(k, 8)
        Sheet2.Cells(r, 9) = Sheet1.Cells(k, 9)
        Sheet2.Cells(r, 10) = Sheet1.Cells(k, 10)
        Sheet2.Cells(r, 11) = Sheet1.Cells(k, 11)
        Sheet2.Cells(r, 12) = Sheet1.Cells(k, 12)
        Sheet2.Cells(r, 13) = Sheet1.Cells(k, 13)
    ElseIf Sheet1.Cells(k, 13) = "1000002" Then
        Sheet3.Cells(r, 2) = Sheet1.Cells(k, 2)
        Sheet3.Cells(r, 3) = Sheet1.Cells(k, 3)
        Sheet3.Cells(r, 4) = Sheet1.Cells(k, 4)
        Sheet3.Cells(r, 5) = Sheet1.Cells(k, 5)
        Sheet3.Cells(r, 6) = Sheet1.Cells(k, 6)
        Sheet3.Cells(r, 7) = Sheet1.Cells(k, 7)
        Sheet3.Cells(r, 8) = Sheet1.Cells(k, 8)
        Sheet3.Cells(r, 9) = Sheet1.Cells(k, 9)
        Sheet3.Cells(r, 10) = Sheet1.Cells(k, 10)
        Sheet3.Cells(r, 11) = Sheet1.Cells(k, 11)
        Sheet3.Cells(r, 12) = Sheet1.Cells(k, 12)
        Sheet3.Cells(r, 13) = Sheet1.Cells(k, 13)
    Else
        Sheet4.Cells(r, 2) = Sheet1.Cells(k, 2)
        Sheet4.Cells(r, 3) = Sheet1.Cells(k, 3)
        Sheet4.Cells(r, 4) = Sheet1.Cells(k, 4)
        Sheet4.Cells(r, 5) = Sheet1.Cells(k, 5)
        Sheet4.Cells(r, 6) = Sheet1.Cells(k, 6)
        Sheet4.Cells(r, 7) = Sheet1.Cells(k, 7)
        Sheet4.Cells(r, 8) = Sheet1.Cells(k, 8)
        Sheet4.Cells(r, 9) = Sheet1.Cells(k, 9)
        Sheet4.Cells(r, 10) = Sheet1.Cells(k, 10)
        Sheet4.Cells(r, 11) = Sheet1.Cells(k, 11)
        Sheet4.Cells(r, 12) = Sheet1.Cells(k, 12)
        Sheet4.Cells(r, 13) = Sheet1.Cells(k, 13)
    End If
End If
r = r + 1
Next
Application.ScreenUpdating = True
End Sub

[lumi]

ขอโทษด้วยค่ะที่ดูไม่ครบตอนนี้ run ข้อมูลมาครบทุก sheet แต่ไม่ได้เริ่มที่บรรทัดที่ 20 ทุก sheet ค่ะ
มันจะเลื่อนลงไปเรื่อย ๆ แก้ไข code ยังไงดีคะ

[DhitiBank]

ลองปรับโค้ดแบบนี้ดูครับ

Code: Select all

Private Sub CmdCopy_Click()
    Dim r As Range, r2 As Range, rSource As Range, _
        i As Integer
    With ActiveSheet
        i = Application.CountIf(.Range("a:a"), "*Vendor*")
        If i > 0 Then
            Set r2 = .Range("b1")
            For Each r In .Range("a1", .Range("a" & .Rows.Count).End(xlUp))
                If Trim(r.Value) = "Vendor" Then
                    Set r2 = .Range("b:b").Find(what:="~*~*", after:=r2)
                    i = VBA.Right(Trim(r.End(xlToRight).Value), 1)
                    If i > 0 Then
                        Set rSource = r.Resize(r2.Row - r.Row + 2, 13)
                        Sheets(i + 1).Range("a11:m1000").ClearContents
                        Sheets(i + 1).Range("a11").Resize(rSource.Rows.Count, _
                            rSource.Columns.Count).Value = rSource.Value
                    End If
                End If
            Next r
        End If
    End With
End Sub

[lumi]

ขอบคุณมากค่ะคุณ DhitiBank ลองปรับดูแล้วสามารถ run ได้ค่ะ แต่ถ้าเป็น file งานจริง vendor
จะไม่ได้เรียง 1000001, 100002, 100003 ค่ะ และบาง vendor ก็จะไม่มีข้อมูลในบางเดือน ตาม file ที่แนบมาใหม่
ทำให้ code ไม่สามารถ run ได้ค่ะ ต้องปรับแบบไหนดีคะ

[snasui]

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

Code: Select all

Dim rAll As Range, r As Range
Dim rSource As Range, iCount As Long
With Sheets("data")
    Set rAll = .Range("b:b").SpecialCells(xlCellTypeConstants)
    For Each r In rAll
        If r.Value = "**" Then
            r.Offset(-1, -1).Value = r.Offset(-2, 0).Value
        End If
    Next r
    Set rAll = .Range("a:a").SpecialCells(xlCellTypeConstants)
    For Each r In rAll
        If InStr(r.Value, "Vendor") Then
            Set rSource = .Range(r, r.Offset(5, 0).End(xlDown).Offset(-1, 0)).Resize(, 13)
            iCount = iCount + 1
            With Sheets(.Index + iCount)
            .UsedRange.Clear
            .Range("a1").Resize(rSource.Rows.Count, rSource.Columns.Count) _
                    .Value = rSource.Value
            End With
        End If
    Next r
End With

[lumi]

ได้ทดลองนำ Code ของอาจารย์ snasui มาใช้แล้วโดยปรับนิดหน่อยพอกดปุ่ม Run ข้อมูลไปตาม sheet เรียงเลย
ไม่ไปลงตาม sheet ของ Vendor นั้น ๆ ค่ะ จาก file ที่แนบมา Sheet Vendor CCC เป็นข้อมูลของ Vendor EEE
ต้องทำยังไงคะ

Code: Select all

Private Sub CommandButton2_Click()
Application.ScreenUpdating = False
Dim rAll As Range, r As Range
Dim rSource As Range, iCount As Long
With Sheets("data")
    Set rAll = .Range("b:b").SpecialCells(xlCellTypeConstants)
    For Each r In rAll
        If r.Value = "**" Then
            r.Offset(-1, -1).Value = r.Offset(-2, 0).Value
        End If
    Next r
    Set rAll = .Range("a:a").SpecialCells(xlCellTypeConstants)
    For Each r In rAll
        If InStr(r.Value, "Vendor") Then
            Set rSource = .Range(r, r.Offset(5, 0).End(xlDown).Offset(-1, 0)).Resize(, 13)
            iCount = iCount + 1
            With Sheets(.Index + iCount)
            .Range("a11:m1000").ClearContents
            .Range("a11").Resize(rSource.Rows.Count, rSource.Columns.Count) _
                    .Value = rSource.Value
            End With
        End If
    Next r
End With
Application.ScreenUpdating = True
End Sub

[snasui]

ต้องปรับมาเองครับ Code นั้นเป็นตัวอย่างเท่านั้น ลองปรับมาเอง ติดตรงไหนแล้วค่อยถามกันต่อครับ

[DhitiBank]

จดๆๆๆ
ขอบคุณอาจารย์มากครับ คำสั่ง .SpecialCells นี่เจ๋งจริงๆ

[lumi]

คำสั่งสามแถวนี้ทำงานอย่างไรคะ โดยเฉพาะความหมายของคำสั่งอยากทราบค่ะ
.SpecialCells(xlCellTypeConstants
iCount = iCount + 1
With Sheets(.Index + iCount)

[snasui]

Range("b:b").SpecialCells(xlCellTypeConstants) เป็นการหาค่าคงที่ในคอลัมน์ B ทั้งคอลัมน์ ค่าคงที่เช่น ตัวเลข ตัวอักษร

iCount = iCount + 1 เป็นการเพิ่มค่าตัวแปร iCount ไปทีละ 1

Sheets(.Index + iCount) จาก Statement นี้ ก่อนบรรทัดนี้จะต้องมีระบุว่าเป็นชีตอะไร .Index เป็นลำดับชีตนั้นในไฟล์นี้

Sheets(.Index + iCount) เป็นการเข้าถึงชีตในลำดับที่ตามบรรทัดบนบวกด้วยค่าตัวแปร iCount คือ นำ .Index + iCount มาเป็นลำดับที่ของชีตที่จะจัดการต่อไปครับ

[lumi]

ลองเขียน code ใหม่แล้วค่ะ และสามารถ run ได้แล้วไม่ติดอะไร ขอบคุณมากนะคะ

Code: Select all

Dim i, j, k As Long
Dim wstMain As Worksheet: Set wstMain = Worksheets("data")
Dim lngLastRow As Long: lngLastRow = wstMain.Cells(Cells.Rows.Count, 2).End(xlUp).Row
Dim strVendorCode As String
Dim lngLastrow_copy
Debug.Print wstMain.Index
wstMain.Activate
For i = 1 To lngLastRow
    If Trim(Cells(i, 1)) = "Vendor" Then
        strVendorCode = Cells(i, 6)
    For j = i To lngLastRow
        If Trim(Cells(j, 2)) = "**" Then
            lngLastrow_copy = j - 1
            Range(Cells(i, 1), Cells(lngLastrow_copy, 13)).Copy
            For k = (wstMain.Index + 1) To Sheets.Count
                If Trim(Sheets(k).Range("F2")) = strVendorCode Then
                    Sheets(k).Range("A11").PasteSpecial xlPasteValues
                    Sheets(k).Range("A11").PasteSpecial xlPasteFormats
                    Application.CutCopyMode = False
                End If
            Next
            i = j
            GoTo skipJ
        End If
    Next
    End If
skipJ:
Next
End Sub

[snasui]

ยินดีด้วยครับ

ตัวอย่างการปรับ Code ที่ผมตอบไปครับ

Code: Select all

Dim rAll As Range, r As Range
Dim rSource As Range, iCount As Long
With Sheets("data")
    Set rAll = .Range("b:b").SpecialCells(xlCellTypeConstants)
    For Each r In rAll
        If r.Value = "**" Then
            r.Offset(-1, -1).Value = r.Offset(-2, 0).Value
        End If
    Next r
    Set rAll = .Range("a:a").SpecialCells(xlCellTypeConstants)
    For Each r In rAll
        If InStr(r.Value, "Vendor") Then
            Set rSource = .Range(r, r.Offset(5, 0).End(xlDown).Offset(-1, 0)).Resize(, 13)
            With Sheets("Vendor " & r.Offset(3, 5).Value)
            .Range("a11:m1000").Clear
            .Range("a11").Resize(rSource.Rows.Count, rSource.Columns.Count) _
                    .Value = rSource.Value
            End With
        End If
    Next r
End With

หรือ นำ Array เข้ามาช่วย

Code: Select all

Dim r As Range, j%, a(0 To 999, 3)
With Sheets("data")
    For Each r In .Range("a2", .Range("b" & .Rows.Count) _
        .End(xlUp)).Columns(1).Cells
        If InStr(r.Value, "Vendor") Then
            a(j, 0) = r.Row
            a(j, 1) = r.Offset(3, 5).Value
        End If
        If r.Offset(0, 1).Value = "**" Then
            a(j, 2) = r.Row - 2
            a(j, 3) = .Cells(a(j, 0), 1) _
                .Resize(a(j, 2) - a(j, 0) + 1, 13).Address
            Sheets("Vendor " & a(j, 1)).Range("a11") _
                .Resize(Range(a(j, 3)).Rows.Count, 13) _
                .Value = .Range(a(j, 3)).Value
            j = j + 1
        End If
    Next r
End With

[lumi]

ขอบคุณมากเลยค่ะอาจารย์ ได้ความรู้เพิ่มขึ้นเยอะเลย
สงสัยต้องไปศึกษาการใช้คำสั่ง offset เพิ่มแล้วหล่ะค่ะ
ตอนนี้เขียนเป็นแต่แบบง่าย ๆ เอง