นำยอดtotalจากทุกชีทมารวมไว้ในชีทเดียวแบบเรียงลำดับลงมาเรื่อยๆ

[kio2002]

นำยอดtotalจากทุกชีทมารวมไว้ในชีทเดียวแบบเรียงลำดับลงมาเรื่อยๆ
ผมต้องการนำยอดtotalจากทุกชีทมารวมไว้ที่ชีท"รวมสรุปยอด"โดยเรียงลำดับลงมาเรื่อยๆ
ยอดtotalจะอยู่ที่เซลล์D5ทุกชีทครับ
(ต้องขออภัยด้วยครับ ไฟล์นี้ผมยกตัวอย่างมา เนื่องจากไฟล์ของจริง ไม่สามารถเปิดเผยได้)
code ที่ได้เขียนไว้ มีดังนี้ครับ

Code: Select all

Sub Button2_Click()
    Sheets("sheet2").Select
        Range("d5").Copy
        Sheets("ÃÇÁÊÃØ»ÂÍ´").Select
        Range("A2").Select
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Sheets("sheet3").Select
        Range("d5").Copy
        Sheets("ÃÇÁÊÃØ»ÂÍ´").Select
        Range("A3").Select
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Sheets("sheet4").Select
        Range("d5").Copy
        Sheets("ÃÇÁÊÃØ»ÂÍ´").Select
        Range("A4").Select
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Sheets("sheet5").Select
        Range("d5").Copy
        Sheets("ÃÇÁÊÃØ»ÂÍ´").Select
        Range("A5").Select
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Sheets("sheet6").Select
        Range("d5").Copy
        Sheets("ÃÇÁÊÃØ»ÂÍ´").Select
        Range("A6").Select
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
End Sub

แต่ติดตรงที่ว่า ผมต้อง new sheet ขึ้นมาเรื่อยๆ เป็นร้อยๆชีท และมีการเปลี่ยนชื่อชีททุกชีทด้วย
จึงรบกวนสมาชิกทุกๆท่านช่วยหน่อยครับ

ขอบคุณมากๆครับ

[snasui]

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

Code: Select all

Sub Button2_Click()
    Dim sh As Worksheet   
    Worksheets("รวมสรุปยอด").Range("a2:a1000").ClearContents
    For Each sh In Worksheets
        If sh.Name <> "รวมสรุปยอด" Then
            With Worksheets("รวมสรุปยอด")
                .Range("a" & .Rows.Count).End(xlUp).Offset(1, 0).Value = sh.Range("d5").Value
            End With
        End If
    Next sh
End Sub

[kio2002]

ขอบคุณมากครับ
code ตรงตามที่ต้องการเลยครับอาจารย์
แต่ผมปรับให้มันเริ่มวางตั้งแต่เซลล์ A2ลงมา ปรากฎว่ามันดึงค่าเฉพาะชีทสุดท้ายมา
รบกวนอาจารย์ช่วยหน่อยครับ

Code: Select all

Sub Button2_Click()
    Dim sh As Worksheet
    Worksheets("รวมสรุปยอด").Range("a2:a1000").ClearContents
    For Each sh In Worksheets
        If sh.Name <> "รวมสรุปยอด" Then
            With Worksheets("รวมสรุปยอด")
                .Range("a2", .Range("a" & .Rows.Count)).End(xlUp).Offset(1, 0).Value = sh.Range("d5").Value
            End With
        End If
    Next sh
End Sub

[puriwutpokin]

ใช่ให้ค่าแรกอยู่ที่ A3 หรือเปล่าถ้าใช่ปรับเป็น

Code: Select all

Sub Button2_Click()
    Dim sh As Worksheet
    Worksheets("รวมสรุปยอด").Range("a2:a1000").ClearContents
    For Each sh In Worksheets
        If sh.Name <> "รวมสรุปยอด" Then
            With Worksheets("รวมสรุปยอด")
                 .Range("a3").Offset(Application.CountA(.Range("a3:a" & .Rows.Count)), 0).Value = sh.Range("d5").Value
            End With
        End If
    Next sh
End Sub

[kio2002]

ผมลองใช้ code ของคุณ puriwutpokin แล้วครับ
เซลล์บางคอลัมน์ ค่ามันไม่เริ่มแถวเดียวกัน ทั้งๆที่เขียนcodeให้เริ่มแถวเดียวกัน คือแถวที่4
รบกวนกวนเช็คให้อีกทีครับ

Code: Select all

Sub Button2_Click()
    Dim sh As Worksheet
    Worksheets("รวมสรุปยอด").Range("b4:g31").ClearContents
    For Each sh In Worksheets
        If sh.Name <> "รวมสรุปยอด" Then
            With Worksheets("รวมสรุปยอด")
                 .Range("b4").Offset(Application.CountA(.Range("b4:b" & .Rows.Count)), 0).Value = sh.Range("a4").Value
                 .Range("c4").Offset(Application.CountA(.Range("c4:c" & .Rows.Count)), 0).Value = sh.Range("b4").Value
                 .Range("d4").Offset(Application.CountA(.Range("d4:d" & .Rows.Count)), 0).Value = sh.Range("c4").Value
                 .Range("e4").Offset(Application.CountA(.Range("e4:e" & .Rows.Count)), 0).Value = sh.Range("d4").Value
                 .Range("f4").Offset(Application.CountA(.Range("f4:f" & .Rows.Count)), 0).Value = sh.Range("e4").Value
                 .Range("g4").Offset(Application.CountA(.Range("g4:g" & .Rows.Count)), 0).Value = sh.Range("f4").Value
            End With
        End If
    Next sh
End Sub

ขอบคุณครับ

[puriwutpokin]

ปรับเป็น

Code: Select all

Sub Button2_Click()
    Dim sh As Worksheet
    Worksheets("รวมสรุปยอด").Range("b4:g31").ClearContents
    For Each sh In Worksheets
        If sh.Name <> "รวมสรุปยอด" Then
            With Worksheets("รวมสรุปยอด")
                 .Range("b4:g4").Offset(Application.CountA(.Range("b4:b" & .Rows.Count)), 0).Value = sh.Range("a4:f4").Value
            End With
        End If
    Next sh
End Sub

[menem]

Code: Select all

Sub AllTotal()

    StartRow = 2
    StartCol = 1
    
    TargetCell = "D5"
    
    SheetsCount = ThisWorkbook.Worksheets.Count
    CurrSheet = ActiveSheet.Name
    
'
' Clear Answer Area
'
    WorkRow = StartRow - 1
    For i = 1 To SheetsCount - 1
        WorkRow = WorkRow + 1
        Cells(WorkRow, StartCol).ClearContents
    Next i
    
'
' Put Answer
'
    WorkRow = StartRow - 1
    For i = 1 To SheetsCount
    
        If Worksheets(i).Name <> CurrSheet Then
           WorkRow = WorkRow + 1
           Cells(WorkRow, StartCol).Value = Worksheets(i).Range(TargetCell).Value
        End If
    
    Next i

End Sub

[kio2002]

ปรับเป็น

Code: Select all

Sub Button2_Click()
    Dim sh As Worksheet
    Worksheets("รวมสรุปยอด").Range("b4:g31").ClearContents
    For Each sh In Worksheets
        If sh.Name <> "รวมสรุปยอด" Then
            With Worksheets("รวมสรุปยอด")
                 .Range("b4:g4").Offset(Application.CountA(.Range("b4:b" & .Rows.Count)), 0).Value = sh.Range("a4:f4").Value
            End With
        End If
    Next sh
End Sub

ขอโทดทีครับ คุณ puriwutpokin ข้อมูลจากชีทที่ต้นทาง อาจจะไม่ได้เรียงแบบนี้ครับ

sh.Range("a4:f4").Value

ข้อมูลต้นทางจะกระจายกันอยู่ ขอยกตัวอย่างอีกรอบนะครับ code ตามไฟล์แนบครับ
ขอบคุณครับ

[puriwutpokin]

ปรับเป็น

Code: Select all

Sub Button2_Click()
    Dim sh As Worksheet
    Worksheets("รวมสรุปยอด").Range("b4:g31").ClearContents
    For Each sh In Worksheets
        If sh.Name <> "รวมสรุปยอด" Then
            With Worksheets("รวมสรุปยอด")
                 .Range("b4").Offset(Application.CountA(.Range("b4:b" & .Rows.Count)), 0).Value = sh.Range("b1").Value
                 .Range("c4").Offset(Application.CountA(.Range("c4:c" & .Rows.Count)), 0).Value = sh.Range("b10").Value
                 .Range("d3").Offset(Application.CountA(.Range("d4:d" & .Rows.Count)), 0).Value = sh.Range("b3").Value
                 .Range("e4").Offset(Application.CountA(.Range("e4:e" & .Rows.Count)), 0).Value = sh.Range("b5").Value
                 .Range("f3").Offset(Application.CountA(.Range("f4:f" & .Rows.Count)), 0).Value = sh.Range("c7").Value
                 .Range("g3").Offset(Application.CountA(.Range("g4:g" & .Rows.Count)), 0).Value = sh.Range("d7").Value
            End With
        End If
    Next sh
End Sub

[kio2002]

ได้แล้วครับ ของคุณท่านอาจารย์ snasui คุณpuriwutpokin และ คุณ menem ที่คอยช่วยเหลือครับ
code ของคุณ menem ผมจะลองเอาไปปรับใช้นะครับ