Snasui Excel Forum

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
'โค้ดอื่นๆ    

Code: Select all

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

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