Macro รวบรวมข้อมูลจากหลายๆแบบฟอร์ม

[parakorn]

รบกวนสอบถามครับ

ผมต้องการรวบรวมข้อมูลจากหลายชีท โดยแต่ล่ะชีทมีจุดเริ่มที่คำว่า "ลำดับ"
โดยต้องการให้นำข้อมูลมารวมกันที่ Sheet1 พร้อม รหัสสาขา ครับ

Code: Select all

Sub findFR()
Dim a As Range, o As Range, r As Range
Dim i As Integer

For i = 2 To Sheets.Count
        Sheets(i).Select
        
    a = Range.Find(What:="ลำดับ", After:=ActiveCell, LookIn:=xlValues, LookAt:= _
    xlPart, SearchOrder:=xlByRows + 1, SearchDirection:=xlNext, MatchCase:=False _
    , SearchFormat:=False)
   
    r = Range(a).End(xlUp).Row
        Range("a:" & (cell(a, 15).Range)).Copy
        Sheets(1).Select
        
        Range("a" & Rows.Count + 1).PasteSpecial
Next i
End Sub

[snasui]

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

Code: Select all

Dim rs As Range, c As Range
Dim i As Integer
Dim sh As Worksheet
For Each sh In Worksheets
    If sh.Name <> "Sheet1" Then
        Set c = sh.Cells.Find(What:="ÅӴѺ", LookIn:=xlValues).Offset(1, 0)
        If Not c Is Nothing Then
            Set rs = sh.Range(c, sh.Cells(sh.Rows.Count, c.Column).End(xlUp))
            i = rs.Rows.Count
            With Worksheets("Sheet1")
                .Range("a" & .Rows.Count).End(xlUp).Offset(1, 0) _
                    .Resize(i, 15).Value = rs.Resize(, 15).Value
            End With
        End If
    End If
Next sh

[parakorn]

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

Code: Select all

Dim rs As Range, c As Range
Dim i As Integer
Dim sh As Worksheet
For Each sh In Worksheets
    If sh.Name <> "Sheet1" Then
        Set c = sh.Cells.Find(What:="ÅӴѺ", LookIn:=xlValues).Offset(1, 0)
        If Not c Is Nothing Then
            Set rs = sh.Range(c, sh.Cells(sh.Rows.Count, c.Column).End(xlUp))
            i = rs.Rows.Count
            With Worksheets("Sheet1")
                .Range("a" & .Rows.Count).End(xlUp).Offset(1, 0) _
                    .Resize(i, 15).Value = rs.Resize(, 15).Value
            End With
        End If
    End If
Next sh

ขอบคุณครับอาจารย์ แต่ผมอแดปใช้กับรหัสสาขา ผมว่าถ้าสาขาไหนไม่มีคำว่า
"รหัสสาขา" มันจะไม่ปล่อยว่าง แล้วนำข้อมูลชุดถัดไปมาต่อเลย
ต้องปรับแบบไหนให้มันปล่อยว่างครับ และ ผมเขียนโค้ดอีกชุดชื่อว่า "CopySheets"
ใช้รวบรวมแต่ล่ะชีตมาไว้ในไฟล์นี้ แต่ยังติด Error ครับ รบกวนด้วยครับ

[snasui]

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

Code: Select all

Dim rs As Range, c As Range, o As Range
Dim i As Integer, e As Integer
Dim sh As Worksheet
For Each sh In Worksheets
    If sh.Name <> "Sheet1" Then
        Set c = sh.Cells.Find(What:="ÅӴѺ", LookIn:=xlValues).Offset(1, 0)
        Set o = sh.Cells.Find(What:="ÃËÑÊÊÒ¢Ò", LookIn:=xlValues)
        If o.Value = "ÃËÑÊÊÒ¢Ò" Then
            If Not c Is Nothing Then
                Set rs = sh.Range(c, sh.Cells(sh.Rows.Count, c.Column).End(xlUp))
                i = rs.Rows.Count
                With Worksheets("Sheet1")
                    .Range("a" & .Rows.Count).End(xlUp).Offset(1, 0) _
                        .Resize(i, 15).Value = rs.Resize(, 15).Value
                    .Range("p" & .Rows.Count).End(xlUp).Offset(1, 0) _
                        .Resize(i, 1).Value = o.Offset(0, 1).Value
                End With
            End If
        End If
    End If
Next sh

[parakorn]

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

Code: Select all

Dim rs As Range, c As Range, o As Range
Dim i As Integer, e As Integer
Dim sh As Worksheet
For Each sh In Worksheets
    If sh.Name <> "Sheet1" Then
        Set c = sh.Cells.Find(What:="ÅӴѺ", LookIn:=xlValues).Offset(1, 0)
        Set o = sh.Cells.Find(What:="ÃËÑÊÊÒ¢Ò", LookIn:=xlValues)
        If o.Value = "ÃËÑÊÊÒ¢Ò" Then
            If Not c Is Nothing Then
                Set rs = sh.Range(c, sh.Cells(sh.Rows.Count, c.Column).End(xlUp))
                i = rs.Rows.Count
                With Worksheets("Sheet1")
                    .Range("a" & .Rows.Count).End(xlUp).Offset(1, 0) _
                        .Resize(i, 15).Value = rs.Resize(, 15).Value
                    .Range("p" & .Rows.Count).End(xlUp).Offset(1, 0) _
                        .Resize(i, 1).Value = o.Offset(0, 1).Value
                End With
            End If
        End If
    End If
Next sh

PB1 : ลองปรับตามแล้วครับ ถ้าไม่เจอเงื่อนไขอยากให้เป็นช่องว่างเฉพาะคอลัมภ์ P ครับ
แต่โค้ดมันดักไม่ให้ข้อมูลมาเลย เดี๋ยวจะให้ User Manual ใส่ครับผม

PB2: ผมลองใส่ Status Bar เพิ่มเติม ปรากฎว่าข้อมูลถูกรันเรียบร้อย
ตัวเลข Status Bar ยังวิ่งอยู่เลยครับ ต้องแก้แบบไหนครับ

PB3: ในส่วนของการ Copy จากไฟล์ของสาขา มารวมใน WorkSheets
ที่จะรวบรวม ผมได้แนบไฟล์ตัวอย่างมาให้ครับ เป็นไฟล์นามสกุล .xls

[snasui]

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

Code: Select all

Dim rs As Range, c As Range, o As Range
Dim i As Integer, e As Integer
Dim sh As Worksheet
For Each sh In Worksheets
    If sh.Name <> "Sheet1" Then
        Set c = sh.Cells.Find(What:="ÅӴѺ", LookIn:=xlValues).Offset(1, 0)
        Set o = sh.Cells.Find(What:="ÃËÑÊÊÒ¢Ò", LookIn:=xlValues)
        If Not c Is Nothing Then
            Set rs = sh.Range(c, sh.Cells(sh.Rows.Count, c.Column).End(xlUp))
            i = rs.Rows.Count
            With Worksheets("Sheet1")
                .Range("a" & .Rows.Count).End(xlUp).Offset(1, 0) _
                    .Resize(i, 15).Value = rs.Resize(, 15).Value
                If o.Value = "ÃËÑÊÊÒ¢Ò" Then
                    .Range("p" & .Rows.Count).End(xlUp).Offset(1, 0) _
                        .Resize(i, 1).Value = o.Offset(0, 1).Value
                End If
            End With
        End If
    End If
Next sh

ในส่วนของการยกเลิกการแสดง Status Bar ใช้ Statement Application.StatusBar = False ถูกแล้วครับ

แก้ไขให้ Code ปัจจุบันให้ทำงานได้ตามที่ต้องการเสียก่อนแล้วค่อยนำไปประยุกต้ใช้การรวมข้ามไฟล์ ติดตรงไหนค่อยนำมาถามกันต่อครับ

[parakorn]

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

Code: Select all

Dim rs As Range, c As Range, o As Range
Dim i As Integer, e As Integer
Dim sh As Worksheet
For Each sh In Worksheets
    If sh.Name <> "Sheet1" Then
        Set c = sh.Cells.Find(What:="ÅӴѺ", LookIn:=xlValues).Offset(1, 0)
        Set o = sh.Cells.Find(What:="ÃËÑÊÊÒ¢Ò", LookIn:=xlValues)
        If Not c Is Nothing Then
            Set rs = sh.Range(c, sh.Cells(sh.Rows.Count, c.Column).End(xlUp))
            i = rs.Rows.Count
            With Worksheets("Sheet1")
                .Range("a" & .Rows.Count).End(xlUp).Offset(1, 0) _
                    .Resize(i, 15).Value = rs.Resize(, 15).Value
                If o.Value = "ÃËÑÊÊÒ¢Ò" Then
                    .Range("p" & .Rows.Count).End(xlUp).Offset(1, 0) _
                        .Resize(i, 1).Value = o.Offset(0, 1).Value
                End If
            End With
        End If
    End If
Next sh

ในส่วนของการยกเลิกการแสดง Status Bar ใช้ Statement Application.StatusBar = False ถูกแล้วครับ

แก้ไขให้ Code ปัจจุบันให้ทำงานได้ตามที่ต้องการเสียก่อนแล้วค่อยนำไปประยุกต้ใช้การรวมข้ามไฟล์ ติดตรงไหนค่อยนำมาถามกันต่อครับ

ขอบคุณครับอาจารย์