การ copy ข้อมูลข้ามไฟล์โดยการตรวจสอบข้อมูลในช่องว่าง

[wongsaton]

ผมได้ทำการ copy ข้อมูลข้ามไฟล์ได้แล้วครับ แต่ติดปัญหาตรงในการ copy ครั้งต่อไป ผมต้องการ copy ข้อมูลเพียงแค่บางส่วน
พอจะมีวิธีการตั้งเงื่อนไข ตรวจสอบข้อมูลในช่องว่างหรือวิธีอื่นๆบ้างไหมครับ
รบกวนทุกท่านด้วยนะครับ ขอบคุณครับ
ปล.ผมแนบไฟล์ต้นทางและผลลัพธ์ที่ต้องการมาแล้วครับ

[DhitiBank]

ลองปรับช่วง loop ดูครับ เช่น

Code: Select all

'โค้ดอื่นๆ
    For Each strName In strRange
        strFileName = wbMain.Sheets(1).Range(strName)
        Workbooks.Open(strPath & strFileName).Activate
        Set TargetWb = ActiveWorkbook
        
        For i = 1 To 3
            If TargetWb.Sheets(1).Range("b" & Rows.Count).End(xlUp) <> "" Then i = 3
            Set rSource = wbMain.Sheets(1).Range(strName).Offset(9, i - 2).Resize(6, 1)
            rSource.Copy
            TargetWb.Sheets(1).Range("B" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial _
                Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
        Next i

    Next strName
'โค้ดอื่นๆ    

ย้ายการ Set TargetWb เอาไปทำหลังจากเปิดไฟล์ขึ้นมาเลย จะได้ไม่ต้อง Set ทุกครั้งที่คัดลอกข้อมูลไปยังไฟล์เดิม และใส่เงื่อนไขให้ตรวจสอบค่าในคอลัมน์ B ก่อนคัดลอกครับ หากค่าในคอลัมน์ B แถวสุดท้ายที่มีข้อมูลไม่เป็นค่าว่างก็ให้ i = 3 ไปเลย

[wongsaton]

Code: Select all

If TargetWb.Sheets(1).Range("b" & Rows.Count).End(xlUp) <> "" Then i = 3

code error ที่บรรทัดนี้ครับ ไม่สามารถรันได้ครับ รบกวนแนะนำทีครับ ขอบคุณครับ

[DhitiBank]

ลองแนบไฟล์ที่ได้ปรับแล้วมาดูหน่อยได้ไหมครับ เพราะผมรันได้ปกติดีนะครับ

[DhitiBank]

หรือลองแบบนี้ครับ เผื่อกรณีที่ไดเรกทอรี่ปลายทางไม่มีไฟล์ชื่อนั้นๆ อยู่

Code: Select all

Sub Button2_คลิก()
    Dim wbMain As Workbook
    Dim TargetWb As Workbook
    Dim strRange As Variant
    Dim strPath As String, strFileChk As String
    Dim strFileName As String
    Dim strName As Variant
    Dim rSource As Range
    Dim tSource As Range
    Dim i As Integer
    
    Application.ScreenUpdating = False
    Set wbMain = ThisWorkbook
    strPath = "D:\Excle VBA\"
    'strPath = Application.ActiveWorkbook.Path & "\"
    strRange = Array("G14", "K14", "O14")
    
    For Each strName In strRange
        strFileName = wbMain.Sheets(1).Range(strName)
        strFileChk = Dir(strPath & strFileName & "*")
        
        If strFileName <> "" And Len(strFileChk) > 0 Then
                Workbooks.Open(strPath & strFileChk).Activate
                Set TargetWb = ActiveWorkbook
                
                For i = 1 To 3
                    If Not IsEmpty(TargetWb.Sheets(1).Range("b" & Rows.Count).End(xlUp)) Then i = 3
                    Set rSource = wbMain.Sheets(1).Range(strName).Offset(9, i - 2).Resize(6, 1)
                    rSource.Copy
                    TargetWb.Sheets(1).Range("B" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial _
                        Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
                Next i
                
        Else
                MsgBox "ไม่พบเอกสารชื่อ " & strFileName _
                        & vbCrLf & "ในไดเรกทอรี่ " & strPath
        End If
        strFileChk = Dir
        
    Next strName

    Application.ScreenUpdating = True
    MsgBox ("บันทึกข้อมูลแล้ว")
    
    Set wbMain = Nothing
    Set TargetWb = Nothing
    Set rSource = Nothing

End Sub