ขออนุญาตช่วยปรับVBAในการคัดลอกข้อมูลมาวางต่อเรียงกันโดยไม่เอาหัวแถวมาด้วย

9KiTTi · #1

ขออนุญาตช่วยปรับVBAในการคัดลอกข้อมูลมาวางต่อเรียงกันโดยไม่เอาหัวแถวมาด้วย codeที่ผมใช้จะคัดลอกแถวโดยเริ่มจากคอลัมน์AจนถึงAQจากชีทที่มีคำว่าCPอยู่ในชื่อแท็บโดยมีเงื่อนไขว่าข้อมูลในคอลัมน์ตั้งแต่C10ลงมาของชีทที่มีคำว่าCPอยู่ในชื่อแท็บต้องไม่ตรงกับข้อมูลในคอลัมน์C9ลงมาของชีทที่ไม่มีคำว่าCPในชื่อชีทและไม่ใช่ชีทชื่อPaid_Yes Paid_No Main ถ้าค้นหาแล้วข้อมูลไม่ตรงกันให้คัดลอกข้อมูลเฉพาะแถวที่มีข้อมูลไม่ตรงกันในชีทไปวางที่ช่องB6ของชีทชื่อPaid_NO แต่ตอนเอามาวางจะมีหัวแถวติดมาด้วย ไม่เหมือนในชีทชื่อ Paid_Yes ที่จะคัดลอกมาเฉพาะแถวข้อมูลที่ต้องการ รบกวนแนะนำวิธีแก้ไขด้วยครับ ขอบพระคุณครับ

Code: Select all

Sub CopyRowsBasedOnCondition()
    Dim ws As Worksheet
    Dim wsCP As Worksheet
    Dim wsPaidNo As Worksheet
    Dim wsNonCP As Worksheet
    Dim lastRowCP As Long
    Dim lastRowNonCP As Long
    Dim lastRowPaidNo As Long
    Dim i As Long, j As Long
    Dim foundMatch As Boolean

    ' กำหนดชีทที่ต้องการ
    Set wsPaidNo = ThisWorkbook.Sheets("Paid_No")
    lastRowPaidNo = wsPaidNo.Cells(wsPaidNo.Rows.Count, "B").End(xlUp).Row
    
    ' ลูปผ่านชีทที่มีคำว่า "CP" ในชื่อ
    For Each wsCP In ThisWorkbook.Sheets
        If InStr(1, wsCP.Name, "CP") > 0 Then
            lastRowCP = wsCP.Cells(wsCP.Rows.Count, "C").End(xlUp).Row

            ' ลูปผ่านชีทที่ไม่มีคำว่า "CP" ในชื่อ และไม่ใช่ชีท "Paid_Yes", "Paid_No", "Main"
            For Each ws In ThisWorkbook.Sheets
                If Not InStr(1, ws.Name, "CP") > 0 And ws.Name <> "Paid_Yes" And ws.Name <> "Paid_No" And ws.Name <> "Main" Then
                    lastRowNonCP = ws.Cells(ws.Rows.Count, "C").End(xlUp).Row

                    ' ลูปผ่านข้อมูลในคอลัมน์ C ของชีท CP
                    For i = 10 To lastRowCP
                        foundMatch = False
                        
                        ' ลูปผ่านข้อมูลในคอลัมน์ C ของชีท Non-CP
                        For j = 9 To lastRowNonCP
                            If wsCP.Cells(i, "C").Value = ws.Cells(j, "C").Value Then
                                foundMatch = True
                                Exit For
                            End If
                        Next j
                        
                        ' ถ้าไม่พบข้อมูลที่ตรงกัน ให้คัดลอกแถวนั้นไปวางในชีท Paid_No
                        If Not foundMatch Then
                            wsCP.Range(wsCP.Cells(i, "A"), wsCP.Cells(i, "AQ")).Copy
                            wsPaidNo.Cells(lastRowPaidNo + 1, "B").PasteSpecial Paste:=xlPasteValues
                            lastRowPaidNo = lastRowPaidNo + 1
                        End If
                    Next i
                End If
            Next ws
        End If
    Next wsCP
    
    Application.CutCopyMode = False
End Sub

9KiTTi · #2

ผมปรับ code ให้นำเข้าข้อมูลได้อย่างที่ต้องการแล้ว ติดแค่ช่องที่จะวางไม่ใช่ B6 ในชีทชื่อ Pain_No อย่างที่ต้องการ รบกวนขอคำแนะนำด้วยครับ ขอบพระคุณครับ

Code: Select all

Sub Paid_N()

    Dim wsCP As Worksheet
    Dim ws As Worksheet
    Dim wsTarget As Worksheet
    Dim lastRowCP As Long, lastRow As Long
    Dim i As Long, j As Long
    Dim found As Boolean

    ' Set the target sheet
    Set wsTarget = ThisWorkbook.Sheets("Paid_NO")
    
    ' Clear existing data in Paid_NO from B6 downwards
    wsTarget.Range("B6:B" & wsTarget.Cells(wsTarget.Rows.Count, "B").End(xlUp).Row).ClearContents

    ' Loop through each sheet in the workbook
    For Each wsCP In ThisWorkbook.Sheets
        ' Check if the sheet name contains "CP"
        If InStr(1, wsCP.Name, "CP", vbTextCompare) > 0 Then
            lastRowCP = wsCP.Cells(wsCP.Rows.Count, "C").End(xlUp).Row
            
            ' Loop through each row starting from row 10
            For i = 10 To lastRowCP
                found = False
                
                ' Check other sheets
                For Each ws In ThisWorkbook.Sheets
                    If ws.Name <> wsCP.Name And ws.Name <> "Paid_Yes" And ws.Name <> "Paid_No" And ws.Name <> "Main" Then
                        lastRow = ws.Cells(ws.Rows.Count, "C").End(xlUp).Row
                        
                        ' Compare with rows in other sheets from row 9 downwards
                        For j = 9 To lastRow
                            If wsCP.Cells(i, "C").Value = ws.Cells(j, "C").Value Then
                                found = True
                                Exit For
                            End If
                        Next j
                        
                        If found Then Exit For
                    End If
                Next ws
                
                ' If not found in any other sheet, copy the row to Paid_NO
                If Not found Then
                    wsCP.Range("A" & i & ":AQ" & i).Copy
                    wsTarget.Range("B" & wsTarget.Cells(wsTarget.Rows.Count, "B").End(xlUp).Row + 1).PasteSpecial xlPasteValues
                End If
            Next i
        End If
    Next wsCP
    
    ' Clear the clipboard
    Application.CutCopyMode = False

    MsgBox "Data copy process is complete!"

End Sub

End Sub

snasui · #3

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

Code: Select all

'Other code            ' ลูปผ่านชีทที่ไม่มีคำว่า "CP" ในชื่อ และไม่ใช่ชีท "Paid_Yes", "Paid_No", "Main"
            For Each ws In ThisWorkbook.Sheets
                If Not InStr(1, ws.Name, "CP") > 0 And ws.Name <> "Paid_Yes" And ws.Name <> "Paid_No" And ws.Name <> "Main" Then
                    lastRowNonCP = ws.Cells(ws.Rows.Count, "C").End(xlUp).Row

                    ' ลูปผ่านข้อมูลในคอลัมน์ C ของชีท CP
                    For i = 10 To lastRowCP
                        If Not IsEmpty(wsCP.Cells(i, "A")) And IsNumeric(wsCP.Cells(i, "A")) Then
                            foundMatch = False
                            
                            ' ลูปผ่านข้อมูลในคอลัมน์ C ของชีท Non-CP
                            For j = 9 To lastRowNonCP
                                If wsCP.Cells(i, "C").Value = ws.Cells(j, "C").Value Then
                                    foundMatch = True
                                    Exit For
                                End If
                            Next j
                            
                            ' ถ้าไม่พบข้อมูลที่ตรงกัน ให้คัดลอกแถวนั้นไปวางในชีท Paid_No
                            If Not foundMatch Then
                                wsCP.Range(wsCP.Cells(i, "A"), wsCP.Cells(i, "AQ")).Copy
                                wsPaidNo.Cells(lastRowPaidNo + 1, "B").PasteSpecial Paste:=xlPasteValues
                                lastRowPaidNo = lastRowPaidNo + 1
                            End If
                        End If
                    Next i
                End If
            Next ws
'Other code

ดูเหมือนจะได้ค่าซ้ำ ๆ มาด้วย

สำหรับ Code ด้านล่างจะนำมาใช้เฉพาะค่าที่ไม่ซ้ำครับ

Code: Select all

Sub CopyRowsBasedOnCondition_()
     Dim dCp As Object, strCp As String, rngCPs As Range, rngCp As Range
     Dim dnCp As Object, strNcp As String, rngNCps As Range, rngNcp As Range
     Dim sh As Worksheet, itm As Variant, i As Integer, strShN As String, rw As Integer
     
     Set dCp = CreateObject("Scripting.Dictionary")
     Set dnCp = CreateObject("Scripting.Dictionary")
     For Each sh In Worksheets
        If InStr(sh.Name, "CP") Then
            Set rngCPs = sh.Range("c10", sh.Range("c" & sh.Rows.Count).End(xlUp))
            For Each rngCp In rngCPs
                strCp = CStr(rngCp.Value)
                If IsNumeric(strCp) And Not dCp.Exists(strCp) Then
                    dCp.Add Key:=strCp, Item:=sh.Name & "|" & rngCp.Row
                End If
            Next rngCp
        ElseIf InStr("Main|Paid_No|Paid_Yes|CP", sh.Name) = 0 Then
            Set rngNCps = sh.Range("c9", sh.Range("c" & sh.Rows.Count).End(xlUp))
            For Each rngNcp In rngNCps
                strNcp = CStr(rngNcp.Value)
                If IsNumeric(strNcp) And Not dnCp.Exists(strNcp) Then
                    dnCp.Add Key:=strNcp, Item:=sh.Name & "|" & rngNcp.Row
                End If
            Next rngNcp
        End If
     Next sh
     For Each itm In dCp.keys
        If Not dnCp.Exists(itm) Then
            strShN = VBA.Split(dCp.Item(itm), "|")(0)
            rw = VBA.Split(dCp.Item(itm), "|")(1)
            With Worksheets("Paid_No")
                .Range("a" & .Rows.Count).End(xlUp).Offset(1, 0).Resize(, 177).Value = _
                    Worksheets(strShN).Cells(rw, "a").Resize(, 177).Value
            End With
        End If
     Next itm
End Sub

9KiTTi · #4

snasui wrote: Sun Aug 25, 2024 1:49 pm

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

Code: Select all

'Other code            ' ลูปผ่านชีทที่ไม่มีคำว่า "CP" ในชื่อ และไม่ใช่ชีท "Paid_Yes", "Paid_No", "Main"
            For Each ws In ThisWorkbook.Sheets
                If Not InStr(1, ws.Name, "CP") > 0 And ws.Name <> "Paid_Yes" And ws.Name <> "Paid_No" And ws.Name <> "Main" Then
                    lastRowNonCP = ws.Cells(ws.Rows.Count, "C").End(xlUp).Row

                    ' ลูปผ่านข้อมูลในคอลัมน์ C ของชีท CP
                    For i = 10 To lastRowCP
                        If Not IsEmpty(wsCP.Cells(i, "A")) And IsNumeric(wsCP.Cells(i, "A")) Then
                            foundMatch = False
                            
                            ' ลูปผ่านข้อมูลในคอลัมน์ C ของชีท Non-CP
                            For j = 9 To lastRowNonCP
                                If wsCP.Cells(i, "C").Value = ws.Cells(j, "C").Value Then
                                    foundMatch = True
                                    Exit For
                                End If
                            Next j
                            
                            ' ถ้าไม่พบข้อมูลที่ตรงกัน ให้คัดลอกแถวนั้นไปวางในชีท Paid_No
                            If Not foundMatch Then
                                wsCP.Range(wsCP.Cells(i, "A"), wsCP.Cells(i, "AQ")).Copy
                                wsPaidNo.Cells(lastRowPaidNo + 1, "B").PasteSpecial Paste:=xlPasteValues
                                lastRowPaidNo = lastRowPaidNo + 1
                            End If
                        End If
                    Next i
                End If
            Next ws
'Other code

ดูเหมือนจะได้ค่าซ้ำ ๆ มาด้วย

สำหรับ Code ด้านล่างจะนำมาใช้เฉพาะค่าที่ไม่ซ้ำครับ

Code: Select all

Sub CopyRowsBasedOnCondition_()
     Dim dCp As Object, strCp As String, rngCPs As Range, rngCp As Range
     Dim dnCp As Object, strNcp As String, rngNCps As Range, rngNcp As Range
     Dim sh As Worksheet, itm As Variant, i As Integer, strShN As String, rw As Integer
     
     Set dCp = CreateObject("Scripting.Dictionary")
     Set dnCp = CreateObject("Scripting.Dictionary")
     For Each sh In Worksheets
        If InStr(sh.Name, "CP") Then
            Set rngCPs = sh.Range("c10", sh.Range("c" & sh.Rows.Count).End(xlUp))
            For Each rngCp In rngCPs
                strCp = CStr(rngCp.Value)
                If IsNumeric(strCp) And Not dCp.Exists(strCp) Then
                    dCp.Add Key:=strCp, Item:=sh.Name & "|" & rngCp.Row
                End If
            Next rngCp
        ElseIf InStr("Main|Paid_No|Paid_Yes|CP", sh.Name) = 0 Then
            Set rngNCps = sh.Range("c9", sh.Range("c" & sh.Rows.Count).End(xlUp))
            For Each rngNcp In rngNCps
                strNcp = CStr(rngNcp.Value)
                If IsNumeric(strNcp) And Not dnCp.Exists(strNcp) Then
                    dnCp.Add Key:=strNcp, Item:=sh.Name & "|" & rngNcp.Row
                End If
            Next rngNcp
        End If
     Next sh
     For Each itm In dCp.keys
        If Not dnCp.Exists(itm) Then
            strShN = VBA.Split(dCp.Item(itm), "|")(0)
            rw = VBA.Split(dCp.Item(itm), "|")(1)
            With Worksheets("Paid_No")
                .Range("a" & .Rows.Count).End(xlUp).Offset(1, 0).Resize(, 177).Value = _
                    Worksheets(strShN).Cells(rw, "a").Resize(, 177).Value
            End With
        End If
     Next itm
End Sub

ใช้งานได้แล้วครับอาจารย์ ขอบพระคุณครับ แต่ถ้าต้องการปรับให้ไปวางที่ช่อง B6 ต้องปรับแก้ตรงไหนครับ เพราะตามcodeของอาจารย์ว่างที่ช่องA2ครับ

snasui · #5

ลองปรับส่วนด้านล่างนี้ดู ติดตรงไหนค่อยถามกันต่อครับ

Code: Select all

'Other code
            With Worksheets("Paid_No")
                .Range("a" & .Rows.Count).End(xlUp).Offset(1, 0).Resize(, 177).Value = _
                    Worksheets(strShN).Cells(rw, "a").Resize(, 177).Value
            End With
'Other code

9KiTTi · #6

snasui wrote: Sun Aug 25, 2024 4:34 pm ลองปรับส่วนด้านล่างนี้ดู ติดตรงไหนค่อยถามกันต่อครับ
Code: Select all
'Other code
            With Worksheets("Paid_No")
                .Range("a" & .Rows.Count).End(xlUp).Offset(1, 0).Resize(, 177).Value = _
                    Worksheets(strShN).Cells(rw, "a").Resize(, 177).Value
            End With
'Other code

ใช้ได้ครับอาจารย์ ขออภัยที่เข้ามาแจ้งผลช้าครับ

Snasui Excel Forum

File Anatomy Add-in: ตรวจสอบโครงสร้างไฟล์ Excel อย่างมืออาชีพ

ขออนุญาตช่วยปรับVBAในการคัดลอกข้อมูลมาวางต่อเรียงกันโดยไม่เอาหัวแถวมาด้วย

ขออนุญาตช่วยปรับVBAในการคัดลอกข้อมูลมาวางต่อเรียงกันโดยไม่เอาหัวแถวมาด้วย

Re: ขออนุญาตช่วยปรับVBAในการคัดลอกข้อมูลมาวางต่อเรียงกันโดยไม่เอาหัวแถวมาด้วย

Re: ขออนุญาตช่วยปรับVBAในการคัดลอกข้อมูลมาวางต่อเรียงกันโดยไม่เอาหัวแถวมาด้วย

Re: ขออนุญาตช่วยปรับVBAในการคัดลอกข้อมูลมาวางต่อเรียงกันโดยไม่เอาหัวแถวมาด้วย

Re: ขออนุญาตช่วยปรับVBAในการคัดลอกข้อมูลมาวางต่อเรียงกันโดยไม่เอาหัวแถวมาด้วย

Re: ขออนุญาตช่วยปรับVBAในการคัดลอกข้อมูลมาวางต่อเรียงกันโดยไม่เอาหัวแถวมาด้วย