VBA นำข้อมูล 2 ชุดมาวางต่อสุดท้ายข้อมูลคอลัมน์ A ว่างค่ะ

[suka]

เรียนอาจารย์และท่านผู้รู้ค่ะ

ที่ไฟล์ Form บันทึกข้อมูลไปวางที่ไฟล์ ArBkShare.xlsx ชีท Sheet1 คอลัมน์ A:D และ E:S การวางข้อมูลแต่ละครั้งจำบรรทัดไม่เท่ากันคอลัมน์ A:D อาจจะมีหนึ่งหรือหลายๆบรรทัด แต่คอลัมน์ E:S การวางข้อมูลจะมีเพืยงหนึ่งบรรทัดเท่านั้นค่ะ

ต้วอย่างที่ต้องการไฟล์ ArBkShare.xlsx ชีท Sheet1 ระบายสีเหลืองไว้ค่ะ
ที่ระบายสีแดงยังเป็นปัญหาค่ะ ติดที่ Code นี้ค่ะ ได้แนบ Code ทั้งชุดมาดูว่าควรปรับอย่างไรค่ะ

Code: Select all

With formBook.Sheets("Template")
        .Range("A2:P2").Resize(.Range("Q1")).Copy
         wbShare.Sheets("Sheet1").Range("E" & Rows.Count).End(xlUp) _
            .Offset(1, 0).PasteSpecial xlPasteValues
    End With

Code นำข้อมูลไปวางที่ไฟล์ ArBkShare.xlsx ชีท Sheet1 คอลัมน์ A2:D ค่ะ

Code: Select all

Sub S_BillingDetails()
       'นำข้อมูลไปวางที่ไฟล์ ArBkShare.xlsx ชีท Sheet1 คอลัมน์ A2:D
        Dim formBook As Workbook
        Dim dtShare As Workbook
        Dim mr As Range
        Dim i As Double
        Set formBook = ThisWorkbook
        Set dtShare = Workbooks("ArBkShare.xlsx")
        Set mr = dtShare.Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
        On Error Resume Next
        dtShare.Sheets("Sheet1").ShowAllData
            With formBook.Sheets("Form")
                i = (.Range("P9") + .Range("M12"))
                If i <> .Range("J12") Then
                    Exit Sub
                End If
             End With
   
              With formBook.Sheets("Template")
                      .Range("A20:D20").Resize(.Range("E19")).Copy
                      dtShare.Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp) _
                      .Offset(1, 0).PasteSpecial xlPasteValues
               End With
        dtShare.Save
  End Sub

Code นำข้อมูลไปวางที่ไฟล์ ArBkShare.xlsx ชีท Sheet1 คอลัมน์ E26:S26 ค่ะ

Code: Select all

Sub ArBilling()
    Dim formBook As Workbook
    Dim wbShare As Workbook
    Dim wb As Workbook ' declare wb as workbook
    Dim wdShare As Workbook
    Dim wdShareOpen As Boolean
    Dim rSource As Range
    Dim rTarget As Range
    Dim rs As Range
    Dim rt As Range
    Dim i As Double
    Dim lastRow As Long
    Dim shRange As Range
    Set formBook = ThisWorkbook
    Set wbShare = Workbooks("ArBkShare.xlsx")
    On Error Resume Next
    wbShare.Sheets("Sheet1").ShowAllData
    For Each wb In Workbooks ' loop wb not loop wdShare
        If wb.Name = "WbShare.xlsx" Then
            wdShareOpen = True
        End If
    Next wb
    If Not wdShareOpen Then
   
    End If
   Set wdShare = Workbooks("WbShare.xlsx") 'set wdShare after open not before open
    With formBook.Sheets("Form")
        Set rSource = .Range("B3:B50")
    End With
    With wdShare.Sheets("Sheet1")
        Set rTarget = .Range("F2", .Range("F" & Rows.Count).End(xlUp))
    End With
    With formBook.Sheets("Form")
        i = (.Range("P9") + .Range("M12"))
        If i <> .Range("J12") Then
            MsgBox "โปรดตรวจจำนวนเงินและบันทึกใหม่"
            Exit Sub
        End If
    End With
    Application.Calculation = xlCalculationManual
    For Each rs In rSource
        For Each rt In rTarget
            If rt = rs Then rt.Offset(0, 26) = "B"
        Next rt
    Next rs
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = False
   
    With formBook.Sheets("Template")
        .Range("A2:P2").Resize(.Range("Q1")).Copy
         wbShare.Sheets("Sheet1").Range("E" & Rows.Count).End(xlUp) _
            .Offset(1, 0).PasteSpecial xlPasteValues
    End With
           
    formBook.Sheets("Form").Range("H1,J4:O8,M12").ClearContents
    With formBook.Sheets("Form")
        .Range("j2") = .Range("j2") + 1
        .Range("i4") = .Range("i4") + 1
    End With
       
         wdShare.Save
         wbShare.Save
        formBook.Save
        formBook.Activate
        Range("H1").Select
End Sub

[snasui]

แนบมาเฉพาะที่เป็นปัญหาก็พอไม่จำเป็นต้องแนบมาทั้งหมด Code ที่ไม่มีปัญหาไม่จำเป็นต้องแนบ ไม่ต้องแจ้งมาในกระทู้ครับ

ที่บอกว่าติดนั้น ติดตรงไหน อย่างไร มี Error อะไรขึ้นหรือไม่ แจ้งมาด้วยครับ

[suka]

ค่ะอาจารย์

ไฟล์ ArBkShare.xlsx ชีท Sheet1 Code วางข้อมูลที่เซลล์ E23:S23 ที่ระบายสีแดงไว้ยังปรับไม่ได้ค่ะ ความต้องการปรับ Code ให้ข้อมูลวางที่เซลล์ E26:S26 ค่ะ

[snasui]

ปรับ Code เป็นตามด้านล่างครับ

Code: Select all

'Other code
wbShare.Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp) _
            .Offset(0, 4).PasteSpecial xlPasteValues
'Other code

[suka]

ขอบคุณอาจารย์มากค่ะ ช่วยให้การทำงานเร็วและง่ายขึ้นมากค่ะ