Snasui Excel Forum

Code: Select all

Sub SendDataNunberMinToPP5pratom_Click()
    Dim p As String, directory As String, fileName As String
    Dim tempBook As Workbook, thsBook As Workbook

    Application.ScreenUpdating = False
    
    Set thsBook = ThisWorkbook
    
    p = Range("J1").Value
    With thsBook.Worksheets(p)
        For Each r In .Range("a3", .Range("a" & .Rows.Count).End(xlUp))
            If r.Value <> "" Then
                If r.Value = r.Offset(-1, 0).Value Then
                    t = t & ", " & r.Offset(0, 6).Value
                Else
                    t = r.Offset(0, 6).Value
                End If
                If r.Value <> r.Offset(1, 0).Value Then
                    r.Offset(0, 14).Value = r.Offset(0, 8).Value
                    r.Offset(0, 15).Value = r.Value
                    r.Offset(0, 16).Value = t
                End If
            Else
                Exit For
            End If
        Next r
    End With

    For Each r In thsBook.Sheets(p).Range("o:o").SpecialCells(xlCellTypeConstants)
        directory = r.Value
        fileName = Dir(directory & "*.xl*")
        If fileName <> "" Then
            Set tempBook = Workbooks.Open(directory & fileName)
            tempBook.Worksheets(1).Range("h8").Value = r.Offset(0, 2).Value
            tempBook.Close True
        End If
    Next r

    thsBook.Worksheets(p).Range("o:q").ClearContents
    Application.ScreenUpdating = True
End Sub

Code: Select all

Sub SendDataNunberMinToPP5pratom_Click()
    Dim p, directory As String, fileName As String
    Dim sheet As Worksheet, j, i As Integer 'r
    Dim tempBook As Workbook, thsBook As Workbook
    Dim bookStr As String, rw As Integer
    Dim c As Integer 
    Dim r As Range
    Application.ScreenUpdating = False
    
Set thsBook = ThisWorkbook
    
    p = Range("J1")
   ' directory = Sheets(p).Range("I2").Value
   ' fileName = Dir(directory & "*.xl??")
For Each r In thsBook.Sheets(p).Range("I2:I25")
    directory = r.Value
    fileName = Dir(directory & "*.xl*")
    
    
   ' Set thsBook = ThisWorkbook
    j = 7
    i = 3
Do While fileName <> ""
    Set tempBook = Workbooks.Open(directory & fileName)
    bookStr = VBA.Left(tempBook.Name, 8)
    'On Error Resume Next
    With thsBook.Sheets(p) 'p
        rw = Application.Match(bookStr, .Range("A3:A2000"), 0) - 1
        c = Application.CountIf(.Range("A3:A2000"), bookStr)
        If Err <> 0 Then
            MsgBox "File " & tempBook.Name & " not found in Rows 1."
            Err = 0
        Else
                    With tempBook.Sheets("บันทึกข้อความ")
                            .Range("H8:H8").Resize(c, 1).Value = _
                            thsBook.Worksheets("MinGoPP5T1").Cells(i + rw, j).Resize(c, 1).Value
                            ' ต้องการให้เลขที่เรียงต่อกัน ในเซลเดียวกัน โดยมีคอมม่า กั้นหลังเลขที่ แต่เลขที่สุดท้ายให้ตัดคอมม่าออก
                    End With
            
        End If
        
    End With
    tempBook.Close True
      '  tempBook.Close False
        fileName = Dir()

Loop
  '  MsgBox ("ส่งเลขที่ เข้าชีทบันทึกข้อความ Directory " & r.Value & " เรียบร้อยแล้วค่ะ")

Next r
Application.ScreenUpdating = True

End Sub