VBA แสดงเลขที่เรียงต่อกัน และคั่นด้วยคอมม่า โดยการ Match ชื่อไฟล์ข้าม Workbook

[aueijung]

หากเราต้องการให้ cell H8 ของชีท บันทึกข้อความ ในแต่ละ workbook ตามชื่อไฟล์ ในคอลัมน์ A ของชีท MinGoPP5T1 ไฟล์ ส่งเลขที่นักเรียนเข้าปพ.5.xlsm ที่อยู่ไดร์ฟ D:\ปพ.5\ปีการศึกษา2564\ประถม\เทอม1-2 รับค่าเลขที่ ที่คัดลอกมาจากคอลัมน์ H ชีท MinGoPP5T1 ของไฟล์ ส่งเลขที่นักเรียนเข้าปพ.5.xlsm เหมือนรูปแบบตามตัวอย่าง เช่น 1, 2, 5, 20, 22, 51 ด้วยการเช็ค Match ชื่อไฟล์ โดยไม่ต้องวางเลขที่กระโดดไปยัง cell อื่น ให้วางได้แค่ cell H8 ของชีท บันทึกข้อความ แต่ละ workbook ที่เปิดขึ้นมาเท่านั้น เลขที่สุดท้ายให้ตัดคอมม่าออก เช่น 4, 5, 9, 16
โมดูลที่ใช้คือ Module4

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

เราต้องปรับโค๊ดอย่างไรครับ เพื่อให้ได้ข้อมูล ตามที่ยกตัวอย่างข้างต้นครับผม

[snasui]

ตัวอย่างการปรับ Code ครับ

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

[aueijung]

ขอบพระคุณมากครับอาจารย์ ผมได้รูปแบบคำสั่งโปรแกรมที่อาจารย์ชี้ทางให้ นำไปปรับเล็กน้อย ก็สามารถส่งข้อมูลเข้า ปพ.5 ได้อย่างแม่นยำครับผม ขอบคุณครับผม