ต้องการcopyข้อมูลจากชีทหลักไปยังอีกชีทที่กำหนดแบบเรียงลำดับลงมา

kio2002 · #1

เรียน สมาชิกทุกท่าน
ผมต้องการcopyข้อมูลจากชีทหลักไปยังอีกชีทที่กำหนดแบบเรียงลำดับลงมา
ชีทหลักของผมก็คือชีท"หน้าหลัก"
เมื่อรันโค้ด sub BOQ() อันดับแรกจะให้ตรวจสอบเซลล์ C44 ที่ชีทหน้าหลักก่อน หากไม่เท่ากับค่าว่าง จะให้ exit sub ทันที
หากเป็นค่าว่างก็ให้รันโค้ดตามปกติ
โดยเริ่มcopyข้อมูลจากคอลัมน์ B,C,D,Eแถวที่13ของชีทหน้าหลัก แล้วนำไปวางที่คอลัมน์ B:C,D,E,Fแถวที่12 ของชีทBOQแบบเรียงลำดับลงมาเรื่อยๆตามลำดับครับ ตามที่ผมเข้าใจน่าจะต้องใช้การ loop แต่ลองรันโค้ดแล้วมันcopyมาแค่แถวเดียว คือแถวบนสุด
โค้ดที่ติดปัญหาอยู่ตรงนี้ครับ

Code: Select all

Sub BOQ()
    Dim sh As Worksheet
        With Sheets("หน้าหลัก")
            If .Range("c44").Value <> "" Then
                MsgBox "ช่องบันทึกรายการสินค้าเต็ม ไม่สามารถเพิ่มรายการได้"
                Exit Sub
        End If
        End With
    Worksheets("BOQ").Range("A12:F29").ClearContents
    For Each sh In Worksheets
            With Worksheets("BOQ")
                 .Range("B12").Offset(Application.CountA(.Range("B12:B" & .Rows.Count)), 0).Value = sh.Range("B13").Offset(Application.CountA(.Range("B13:B" & .Rows.Count)), 0).Value
                 .Range("D12").Offset(Application.CountA(.Range("D12:D" & .Rows.Count)), 0).Value = sh.Range("C13").Offset(Application.CountA(.Range("C13:C" & .Rows.Count)), 0).Value
                 .Range("E12").Offset(Application.CountA(.Range("E12:E" & .Rows.Count)), 0).Value = sh.Range("D13").Offset(Application.CountA(.Range("D13:D" & .Rows.Count)), 0).Value
                 .Range("F12").Offset(Application.CountA(.Range("F12:F" & .Rows.Count)), 0).Value = sh.Range("E13").Offset(Application.CountA(.Range("E13:E" & .Rows.Count)), 0).Value
            End With
    Next sh
    MsgBox "Sent To BOQ Complete"
End Sub

snasui · #2

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

Code: Select all

Sub BOQ()
    Dim sh As Worksheet, rw As Long
    With Sheets("หน้าหลัก")
        rw = .Range("b13", .Range("b13").End(xlDown)).Rows.Count
        If .Range("c44").Value <> "" Then
            MsgBox "ช่องบันทึกรายการสินค้าเต็ม ไม่สามารถเพิ่มรายการได้"
            Exit Sub
        End If
    End With
'    Worksheets("BOQ").Range("A12:F29").ClearContents
'    For Each sh In Worksheets
    With Worksheets("BOQ")
        .Range("a12:f29").ClearContents
'            .Range("B12").Offset(Application.CountA(.Range("B12:B" & .Rows.Count)), 0).Value = sh.Range("B13").Offset(Application.CountA(.Range("B13:B" & .Rows.Count)), 0).Value
'            .Range("D12").Offset(Application.CountA(.Range("D12:D" & .Rows.Count)), 0).Value = sh.Range("C13").Offset(Application.CountA(.Range("C13:C" & .Rows.Count)), 0).Value
'            .Range("E12").Offset(Application.CountA(.Range("E12:E" & .Rows.Count)), 0).Value = sh.Range("D13").Offset(Application.CountA(.Range("D13:D" & .Rows.Count)), 0).Value
'            .Range("F12").Offset(Application.CountA(.Range("F12:F" & .Rows.Count)), 0).Value = sh.Range("E13").Offset(Application.CountA(.Range("E13:E" & .Rows.Count)), 0).Value
        .Range("a12").Resize(rw).Value = Worksheets("หน้าหลัก").Range("a13").Resize(rw).Value
        .Range("b12").Resize(rw).Value = Worksheets("หน้าหลัก").Range("b13").Resize(rw).Value
        .Range("d12").Resize(rw).Value = Worksheets("หน้าหลัก").Range("c13").Resize(rw).Value
        .Range("e12").Resize(rw).Value = Worksheets("หน้าหลัก").Range("d13").Resize(rw).Value
        .Range("f12").Resize(rw).Value = Worksheets("หน้าหลัก").Range("e13").Resize(rw).Value
    End With
'    Next sh
    MsgBox "Sent To BOQ Complete"
End Sub

kio2002 · #3

เรียน อาจารย์ snasui
ผมได้นำโค้ดไปทดลองแล้ว ใช้ได้ตามต้องการครับ

พอดีผมอยากให้เติมเส้นขอบเป็นสี่เหลี่ยมในแต่ละเซลล์เรียงลงมาจนถึงข้อความสุดท้ายของคอลัมน์นั้น
ลองเขียนโค้ดแล้ว เจอปัญหา
1 โปรแกรมเติมเส้นขอบแค่แถวล่างสุดแค่แถวเดียว
2 โปรแกรมสร้างหน้าให้อัตโนมัติถึง 14,769 หน้า ทำให้ไฟล์มีขนาดใหญ่ถึง 19.2mb และรันโค้ดได้ช้ามาก

โค้ดที่ติดปัญหาจุดที่ 1

Code: Select all

        ' ลบข้อความ และทำเส้นขอบให้เป็นสีขาว
        .Range("a12:f43").ClearContents
        .Range("a12", Range("a12").End(xlDown)).Borders(xlEdgeLeft).TintAndShade = 0
        .Range("a12", Range("a12").End(xlDown)).Borders(xlEdgeRight).TintAndShade = 0
        .Range("c12", Range("c12").End(xlDown)).Borders(xlEdgeRight).TintAndShade = 0
        .Range("d12", Range("d12").End(xlDown)).Borders(xlEdgeRight).TintAndShade = 0
        .Range("e12", Range("e12").End(xlDown)).Borders(xlEdgeRight).TintAndShade = 0
        .Range("f12", Range("f12").End(xlDown)).Borders(xlEdgeRight).TintAndShade = 0
        .Range("a12", Range("a12").End(xlDown)).Borders(xlEdgeBottom).TintAndShade = 0
        .Range("b12", Range("b12").End(xlDown)).Borders(xlEdgeBottom).TintAndShade = 0
        .Range("c12", Range("c12").End(xlDown)).Borders(xlEdgeBottom).TintAndShade = 0
        .Range("d12", Range("d12").End(xlDown)).Borders(xlEdgeBottom).TintAndShade = 0
        .Range("e12", Range("e12").End(xlDown)).Borders(xlEdgeBottom).TintAndShade = 0
        .Range("f12", Range("f12").End(xlDown)).Borders(xlEdgeBottom).TintAndShade = 0

โค้ดที่ติดปัญหาจุดที่ 2

Code: Select all

        ' เติมเส้นขอบสี เป็นกรอบสีเหลี่ยมในแต่ละเซลล์
        .Range("a12", Range("a12").End(xlDown)).Borders(xlEdgeTop).TintAndShade = -0.14996795556505
        .Range("a12", Range("a12").End(xlDown)).Borders(xlEdgeBottom).TintAndShade = -0.14996795556505
        .Range("a12", Range("a12").End(xlDown)).Borders(xlEdgeRight).TintAndShade = -0.14996795556505
        .Range("a12", Range("a12").End(xlDown)).Borders(xlEdgeLeft).TintAndShade = -0.14996795556505

        .Range("b12", Range("b12").End(xlDown)).Borders(xlEdgeTop).TintAndShade = -0.14996795556505
        .Range("b12", Range("b12").End(xlDown)).Borders(xlEdgeBottom).TintAndShade = -0.14996795556505
        .Range("b12", Range("b12").End(xlDown)).Borders(xlEdgeRight).TintAndShade = -0.14996795556505
        .Range("b12", Range("b12").End(xlDown)).Borders(xlEdgeLeft).TintAndShade = -0.14996795556505

        .Range("d12", Range("d12").End(xlDown)).Borders(xlEdgeTop).TintAndShade = -0.14996795556505
        .Range("d12", Range("d12").End(xlDown)).Borders(xlEdgeBottom).TintAndShade = -0.14996795556505
        .Range("d12", Range("d12").End(xlDown)).Borders(xlEdgeRight).TintAndShade = -0.14996795556505
        .Range("d12", Range("d12").End(xlDown)).Borders(xlEdgeLeft).TintAndShade = -0.14996795556505

        .Range("e12", Range("e12").End(xlDown)).Borders(xlEdgeTop).TintAndShade = -0.14996795556505
        .Range("e12", Range("e12").End(xlDown)).Borders(xlEdgeBottom).TintAndShade = -0.14996795556505
        .Range("e12", Range("e12").End(xlDown)).Borders(xlEdgeRight).TintAndShade = -0.14996795556505
        .Range("e12", Range("e12").End(xlDown)).Borders(xlEdgeLeft).TintAndShade = -0.14996795556505

        .Range("f12", Range("f12").End(xlDown)).Borders(xlEdgeTop).TintAndShade = -0.14996795556505
        .Range("f12", Range("f12").End(xlDown)).Borders(xlEdgeBottom).TintAndShade = -0.14996795556505
        .Range("f12", Range("f12").End(xlDown)).Borders(xlEdgeRight).TintAndShade = -0.14996795556505
        .Range("f12", Range("f12").End(xlDown)).Borders(xlEdgeLeft).TintAndShade = -0.14996795556505

รูปตารางที่อยากได้ประมาณนี้ครับ

snasui · #4

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

Code: Select all

Sub BOQ()
    Dim sh As Worksheet, rw As Long
    Dim r As Range
    Application.ScreenUpdating = False
    With Sheets("หน้าหลัก")
        rw = .Range("b13", .Range("b13").End(xlDown)).Rows.Count
        If .Range("c44").Value <> "" Then
            MsgBox "ช่องบันทึกรายการสินค้าเต็ม ไม่สามารถเพิ่มรายการได้"
            Exit Sub
        End If
    End With
    With Worksheets("BOQ")
        ' ลบข้อความ และทำเส้นขอบให้เป็นสีขาว
        .Range("a12:f43").ClearContents
'        .Range("a12", Range("a12").End(xlDown)).Borders(xlEdgeLeft).TintAndShade = 0
'        .Range("a12", Range("a12").End(xlDown)).Borders(xlEdgeRight).TintAndShade = 0
'        .Range("c12", Range("c12").End(xlDown)).Borders(xlEdgeRight).TintAndShade = 0
'        .Range("d12", Range("d12").End(xlDown)).Borders(xlEdgeRight).TintAndShade = 0
'        .Range("e12", Range("e12").End(xlDown)).Borders(xlEdgeRight).TintAndShade = 0
'        .Range("f12", Range("f12").End(xlDown)).Borders(xlEdgeRight).TintAndShade = 0
'        .Range("a12", Range("a12").End(xlDown)).Borders(xlEdgeBottom).TintAndShade = 0
'        .Range("b12", Range("b12").End(xlDown)).Borders(xlEdgeBottom).TintAndShade = 0
'        .Range("c12", Range("c12").End(xlDown)).Borders(xlEdgeBottom).TintAndShade = 0
'        .Range("d12", Range("d12").End(xlDown)).Borders(xlEdgeBottom).TintAndShade = 0
'        .Range("e12", Range("e12").End(xlDown)).Borders(xlEdgeBottom).TintAndShade = 0
'        .Range("f12", Range("f12").End(xlDown)).Borders(xlEdgeBottom).TintAndShade = 0
'
        
        .Range("a12").Resize(rw).Value = Worksheets("หน้าหลัก").Range("a13").Resize(rw).Value
        .Range("b12").Resize(rw).Value = Worksheets("หน้าหลัก").Range("b13").Resize(rw).Value
        .Range("d12").Resize(rw).Value = Worksheets("หน้าหลัก").Range("c13").Resize(rw).Value
        .Range("e12").Resize(rw).Value = Worksheets("หน้าหลัก").Range("d13").Resize(rw).Value
        .Range("f12").Resize(rw).Value = Worksheets("หน้าหลัก").Range("e13").Resize(rw).Value
        
        For Each r In .Range("a12:f12").Resize(rw)
            r.Borders(xlEdgeTop).TintAndShade = -0.14996795556505
            r.Borders(xlEdgeBottom).TintAndShade = -0.14996795556505
            r.Borders(xlEdgeRight).TintAndShade = -0.14996795556505
            r.Borders(xlEdgeLeft).TintAndShade = -0.14996795556505
        Next r
        ' เติมเส้นขอบให้เป็นสีเป็นกรอบสีเหลี่ยมในแต่ละเซลล์
'        .Range("a12", Range("a12").End(xlDown)).Borders(xlEdgeTop).TintAndShade = -0.14996795556505
'        .Range("a12", Range("a12").End(xlDown)).Borders(xlEdgeBottom).TintAndShade = -0.14996795556505
'        .Range("a12", Range("a12").End(xlDown)).Borders(xlEdgeRight).TintAndShade = -0.14996795556505
'        .Range("a12", Range("a12").End(xlDown)).Borders(xlEdgeLeft).TintAndShade = -0.14996795556505
'
'        .Range("b12", Range("b12").End(xlDown)).Borders(xlEdgeTop).TintAndShade = -0.14996795556505
'        .Range("b12", Range("b12").End(xlDown)).Borders(xlEdgeBottom).TintAndShade = -0.14996795556505
'        .Range("b12", Range("b12").End(xlDown)).Borders(xlEdgeRight).TintAndShade = -0.14996795556505
'        .Range("b12", Range("b12").End(xlDown)).Borders(xlEdgeLeft).TintAndShade = -0.14996795556505
'
'        .Range("d12", Range("d12").End(xlDown)).Borders(xlEdgeTop).TintAndShade = -0.14996795556505
'        .Range("d12", Range("d12").End(xlDown)).Borders(xlEdgeBottom).TintAndShade = -0.14996795556505
'        .Range("d12", Range("d12").End(xlDown)).Borders(xlEdgeRight).TintAndShade = -0.14996795556505
'        .Range("d12", Range("d12").End(xlDown)).Borders(xlEdgeLeft).TintAndShade = -0.14996795556505
'
'        .Range("e12", Range("e12").End(xlDown)).Borders(xlEdgeTop).TintAndShade = -0.14996795556505
'        .Range("e12", Range("e12").End(xlDown)).Borders(xlEdgeBottom).TintAndShade = -0.14996795556505
'        .Range("e12", Range("e12").End(xlDown)).Borders(xlEdgeRight).TintAndShade = -0.14996795556505
'        .Range("e12", Range("e12").End(xlDown)).Borders(xlEdgeLeft).TintAndShade = -0.14996795556505
'
'        .Range("f12", Range("f12").End(xlDown)).Borders(xlEdgeTop).TintAndShade = -0.14996795556505
'        .Range("f12", Range("f12").End(xlDown)).Borders(xlEdgeBottom).TintAndShade = -0.14996795556505
'        .Range("f12", Range("f12").End(xlDown)).Borders(xlEdgeRight).TintAndShade = -0.14996795556505
'        .Range("f12", Range("f12").End(xlDown)).Borders(xlEdgeLeft).TintAndShade = -0.14996795556505
        
        Application.ScreenUpdating = True
        MsgBox "Sent To BOQ Complete"
        .Select
    End With
End Sub

kio2002 · #5

เรียนอาจารย์ snasui
ผมได้นำโค้ดไปทดสอบแล้ว โค้ดอาจารย์สุดยอดเลยครับ ใช้ได้ผลดีเลยครับ
ขอบคุณมากๆครับ

ผมรบกวนอาจารย์อธิบายเรื่องการใช้ Resize ให้หน่อยครับ
ถ้าตามที่ผมเข้าใจ จะนำมาใช้ในกรณีที่เซลล์ต้นทาง หรือปลายทางมีการผสานเซลล์ใช่ไหมครับ

และก็ผมขอนุญาตใช้กระทู้นี้สอบถามเรื่องโค้ดอื่นเพิ่มเติมได้ไหมครับ หรือต้องตั้งกระทู้ใหม่
โค้ดที่จะสอบถามอาจารย์
ผมต้องการให้เปิด userform กรณีที่มีการดับเบิ้ลคลิกที่เซลล์ระหว่าง C13:C44 หากเซลล์นั้นๆมีค่าว่างก็ให้เปิด userform
หากไม่มีค่าว่างก็ไมต้องดำเนินการใดๆ
เนื่องจากเซลล์มีจำนวนเยอะ ถ้าเขียนโค้ดที่ละเซลล์ จะค่อนข้างเยอะมาก จึงอยากเขียนโค้ดให้สั้นกว่านี้ครับ

โค้ดที่ผมเขียนไว้ประมาณนี้ครับ

Code: Select all

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    If Target.Address = Range("C13").Address Then
        If range("C13").Value = "" Then
            UserForm1.Show
        Cancel = True
        End If
    End If
    If Target.Address = Range("C14").Address Then
        If Range("C14").Value = "" Then
            UserForm1.Show
        Cancel = True
        End If
    End If
    If Target.Address = Range("C15").Address Then
        If Range("C15").Value = "" Then
            UserForm1.Show
        Cancel = True
        End If
    End If
End Sub

snasui · #6

kio2002 wrote: Fri Sep 30, 2022 4:52 pm ผมรบกวนอาจารย์อธิบายเรื่องการใช้ Resize ให้หน่อยครับ
ถ้าตามที่ผมเข้าใจ จะนำมาใช้ในกรณีที่เซลล์ต้นทาง หรือปลายทางมีการผสานเซลล์ใช่ไหมครับ

เป็นการขยายขอบเขตข้อมูล ใน Resize จะต้องระบุจำนวนบรรทัดหรือคอลัมน์ เช่น .Resize(5,2) แปลว่าขยายไป 5 บรรทัด 2 คอลัมน์, .Resize(,8) หมายถึงขยายไป 8 คอลัมน์ส่วนของเดิมมีกี่บรรทัดก็ใช้ตามนั้น, .Resize(10) แปลว่าขยายไป 10 บรรทัด (ไม่ได้ระบุคอลัมน์)

kio2002 wrote: Fri Sep 30, 2022 4:52 pm และก็ผมขอนุญาตใช้กระทู้นี้สอบถามเรื่องโค้ดอื่นเพิ่มเติมได้ไหมครับ หรือต้องตั้งกระทู้ใหม่

กรณีไม่เกี่ยวข้องกับคำถามเดิมกรุณาตั้งกระทู้ใหม่ครับ

kio2002 · #7

snasui wrote: Fri Sep 30, 2022 7:58 pm
kio2002 wrote: Fri Sep 30, 2022 4:52 pm ผมรบกวนอาจารย์อธิบายเรื่องการใช้ Resize ให้หน่อยครับ
ถ้าตามที่ผมเข้าใจ จะนำมาใช้ในกรณีที่เซลล์ต้นทาง หรือปลายทางมีการผสานเซลล์ใช่ไหมครับ
เป็นการขยายขอบเขตข้อมูล ใน Resize จะต้องระบุจำนวนบรรทัดหรือคอลัมน์ เช่น .Resize(5,2) แปลว่าขยายไป 5 บรรทัด 2 คอลัมน์, .Resize(,8) หมายถึงขยายไป 8 คอลัมน์ส่วนของเดิมมีกี่บรรทัดก็ใช้ตามนั้น, .Resize(10) แปลว่าขยายไป 10 บรรทัด (ไม่ได้ระบุคอลัมน์)

kio2002 wrote: Fri Sep 30, 2022 4:52 pm และก็ผมขอนุญาตใช้กระทู้นี้สอบถามเรื่องโค้ดอื่นเพิ่มเติมได้ไหมครับ หรือต้องตั้งกระทู้ใหม่
กรณีไม่เกี่ยวข้องกับคำถามเดิมกรุณาตั้งกระทู้ใหม่ครับ

ได้ตั้งกระทู้ใหม่แล้วครับ ขอบคุณครับ

Snasui Excel Forum

File Anatomy Add-in: ตรวจสอบโครงสร้างไฟล์ Excel อย่างมืออาชีพ

ต้องการcopyข้อมูลจากชีทหลักไปยังอีกชีทที่กำหนดแบบเรียงลำดับลงมา

ต้องการcopyข้อมูลจากชีทหลักไปยังอีกชีทที่กำหนดแบบเรียงลำดับลงมา

Re: ต้องการcopyข้อมูลจากชีทหลักไปยังอีกชีทที่กำหนดแบบเรียงลำดับลงมา

Re: ต้องการcopyข้อมูลจากชีทหลักไปยังอีกชีทที่กำหนดแบบเรียงลำดับลงมา

Re: ต้องการcopyข้อมูลจากชีทหลักไปยังอีกชีทที่กำหนดแบบเรียงลำดับลงมา

Re: ต้องการcopyข้อมูลจากชีทหลักไปยังอีกชีทที่กำหนดแบบเรียงลำดับลงมา

Re: ต้องการcopyข้อมูลจากชีทหลักไปยังอีกชีทที่กำหนดแบบเรียงลำดับลงมา

Re: ต้องการcopyข้อมูลจากชีทหลักไปยังอีกชีทที่กำหนดแบบเรียงลำดับลงมา