แสดงข้อมูลหน้า Forms ตามเงื่อนไข

[wisitsakbenz]

เรียน อาจารย์

ป้อนข้อมูลใน Q1-Q5 หรืออาจจะไม่ป้อนทั้งหมด แล้วคลิกปุ่ม Preview หลังจากนั้นข้อมูลจะถูกใส่ใน Sheet "Forms"
1. ต้องการให้ในแต่ละ Question มีเว้นบรรทัดประมาณ 20 บรรทัด แล้วค่อยขึ้น Question ใหม่
2. Default ในหน้า Forms มีแค่หน้าเดียว หากใน 1 หน้าไม่พอ ให้แสดงหัวข้อใหม่ในหน้าใหม่
3. จัดรูปแบบเส้นขอบตามหน้าแรก (ตาม Sheet ที่ต้องการ)
ต้องปรับ Code อย่างไรครับ ขอบคุณครับ

Code: Select all

Sub Preview()

'Define abbreviations for worksheets
    Dim WI As Worksheet
    Dim WF As Worksheet
    Set WI = Worksheets("Input")
    Set WF = Worksheets("Forms")
       
    
'Detailed Question
    Dim AmountCell1 As Range
    Dim HeadingRow1 As Integer
    Dim CurrentRow1 As Integer
         
    HeadingRow1 = WF.Range("FormsFirstLine1").Row
    CurrentRow1 = HeadingRow1
    
    For Each AmountCell1 In WI.Range("Question").Cells
        If AmountCell1 <> "" Then
            WF.Cells(HeadingRow1, 6) = ""
            CurrentRow1 = CurrentRow1 + 1
            WF.Cells(CurrentRow1, 2) = AmountCell1.Text
            CurrentRow1 = CurrentRow1 + 20

        End If
    Next    
End Sub

[snasui]

ที่เขียนเอาไว้แล้วมีปัญหาอะไรครับ

สำหรับการทำงานตามที่อธิบายมา เพื่อให้ง่ายควรสร้าง Template ที่มีการจัดรูปแบบเอาไว้เรียบร้อยแล้วเพื่อพร้อมใช้งาน จากนั้นจะ Loop Question ไปวางใน Template แล้ว Copy Template ไปวางยังบรรทัดล่างของข้อมูลก่อนหน้า จะได้ไม่ต้องทำไปจัด Format ไป

สำหรับการแสดงผลเมื่อ Preview จะต้องไปจัดการเรื่อง Print Area และการจัด Layout โดยให้ Set Print Area ถึงข้อมูลในหน้าสุดท้าย หากต้องการให้แสดงผลและ Print ให้พอดีหน้า จะต้องมีการกำหนดความสูงข้อมูลให้เท่ากับจำนวนรายการ สิ่งที่ควรทราบเพิ่มเติมคือ Page Setup อยู่ภายใต้เมนู Page Layout และ Scale to Fit อยู่ภายใต้เมนู Page Layout เช่นกัน

สำหรับ Scale to Fit ให้กำหนด Width เป็น 1 และ กำหนด Height ให้มีจำนวนหน้าเท่ารายการ Question ที่มี

[wisitsakbenz]

เรียน อาจารย์ snasui

ผมลองปรับ Code แต่ยังติด Error อยู่
รบกวนอาจารย์ช่วยปรับ Code ให้หน่อยครับ ขอบคุณครับ

Code: Select all

Sub Preview()

'Define abbreviations for worksheets
    Dim WI As Worksheet
    Dim WF As Worksheet
    Set WI = Worksheets("Input")
    Set ws4 = Worksheets("Forms")
    
ws4.Range("A12").Resize(1000, 1).EntireRow.Delete
ws4.Range("B11:AC1000").ClearContents
          
      'Sheet input
 
                With Sheets("input")
                    Set rDataAll = .Range("B2:B5", .Range("B" & Rows.Count).End(xlUp))
                End With
            i = 12
            For Each r In rDataAll
        If r = rFind Then
            ws4.Range("b" & i).Resize(1, 2).Value = _
                r.Offset(0, 1).Resize(1, 2).Value
                ws4.Range("d" & i).Resize(1, 2).Font.Name = "Arial Unicode MS"
                ws4.Range("d" & i).Resize(1, 2).Font.Size = 12
            
            i = i + 1
        End If
    Next r
    
        With ws4.Range(ws4.Cells(CurrentRow1 - 20, 2), ws4.Cells(CurrentRow1 - 1, 1)).Borders(xlEdgeLeft)
               .LineStyle = xlContinuous
               .ColorIndex = 0
                .TintAndShade = 0
               .Weight = xlMedium
            End With
           
       With ws4.Range(ws4.Cells(CurrentRow1 - 20, 2), ws4.Cells(CurrentRow1 - 1, 30)).Borders(xlEdgeRight)
               .LineStyle = xlContinuous
               .ColorIndex = 0
                .TintAndShade = 0
                .Weight = xlMedium
            End With

    
End Sub

[snasui]

ค่อย ๆ ถามตอบกันไป ควรจะแจ้งให้ทราบด้วยว่าสิ่งที่ทำไปแล้วคืออะไร ติดขัดตรงไหน จะได้เข้าถึงปัญหาโดยเร็วและมีโอกาสที่ไม่ต้องรอคอยนานครับ

จาก Statement If r = rFind Then ไม่ทราบว่า rFind คือะไรครับ

[wisitsakbenz]

เรียน อาจารย์ snasui

มันต้องแก้เป็น หรือไม่ครับ

Code: Select all

if r <> "" Then

[snasui]

ได้ลองแก้แล้วหรือไม่ แก้แล้วได้ผลเป็นอย่างไร ติดขัดตรงส่วนใด ระบุปัญหาที่เป็นแล้วมาได้เลยครับ

[wisitsakbenz]

เรียน อาจารย์

ผมลองปรับ Code แล้ว แต่ยังติดตรงที่เส้นขอบ
- ในแต่ละหัวข้อ จะมีการเว้นบรรทัด 30 บรรทัด แล้วขึ้นหัวข้อใหม่ และจะมีการเว้นบรรทัด 30 บรรทัด
- หากขึ้นหน้าใหม่ จะมีเส้นขอบด้านล่างหน้าแรก และเส้นขอบบนหน้าที่ 2 (ดังตัวอย่าง Sheet " ที่ต้องการ")
ต้องปรับCodeอย่างไรครับ ขอบคุณครับ

Code: Select all

Sub Preview()
    ' Define worksheets
    Dim WI As Worksheet
    Dim WF As Worksheet
    Dim r As Range
    Dim i As Long
    Dim blockStart As Long
    Dim blockEnd As Long
    Dim totalBlocks As Long
    Dim textContent As String
    Dim estimatedLines As Long
    Dim mergeRange As Range

    ' Improve performance
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False

    Set WI = Worksheets("Input")
    Set WF = Worksheets("Forms")
    
    ' Clear old data
    WF.Range("A12").Resize(1000, 1).EntireRow.Delete
    WF.Range("A12:AC1000").ClearContents ' Clear both values and formatting
     WF.Range("A12:AC1000").ClearFormats   ' Clear both values and formatting
     
         
    ' Start writing at row 12
    i = 12
    totalBlocks = 0

    ' Loop through cells B2 to B5
    For Each r In WI.Range("B2:B5")
        If r.Value <> "" Then
            ' รวมข้อความจาก B และ C
            textContent = r.Value & vbNewLine & r.Offset(0, 1).Value
            
            ' Define the range to be merged
            Set mergeRange = WF.Range("B" & i & ":AC" & i)
            With mergeRange
                .Merge
                .Value = textContent
                .Font.Name = "Arial Unicode MS"
                .Font.Size = 11
                .HorizontalAlignment = xlLeft
                .VerticalAlignment = xlTop
                .WrapText = True
            End With
                        
            ' ประมาณจำนวนบรรทัด
            estimatedLines = Len(textContent) \ 120 + 1 ' 80 คือจำนวนตัวอักษรต่อแถวโดยประมาณ
            WF.Rows(i).RowHeight = estimatedLines * 20 ' ปรับความสูงแถวให้เหมาะสม

            ' Calculate block range for border
            blockStart = i
            blockEnd = i + 29
                
            ' Add left border in column A (entire block)
            With WF.Range("A" & blockStart & ":A" & blockEnd).Borders(xlEdgeLeft)
                .LineStyle = xlContinuous
                .Weight = xlMedium
                .ColorIndex = 0
            End With

            ' Add right border in column AD (entire block)
            With WF.Range("AD" & blockStart & ":AD" & blockEnd).Borders(xlEdgeRight)
                .LineStyle = xlContinuous
                .Weight = xlMedium
                .ColorIndex = 0
            End With

            ' Add bottom border
            With WF.Range("A" & blockEnd & ":AD" & blockEnd).Borders(xlEdgeBottom)
                .LineStyle = xlContinuous
                .Weight = xlMedium
                .ColorIndex = 0
            End With

            ' Move down 30 rows (increment 30 rows per block)
            i = i + 30
            totalBlocks = totalBlocks + 1
        End If
    Next r

    ' Restore performance settings
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
End Sub

[snasui]

กรณีนี้จำเป็นจะต้องหา Page Break เพื่อตีเส้น

สิ่งที่จะต้องคำนึงคือการแสดง Page Break เผื่อไว้อย่างน้อย 1 หน้าเพื่อตีเส้นของหน้าสุดท้าย การทำเช่นนี้จะต้องประยุกต์โดยเพิ่มข้อมูลเผื่อในชีต Input อย่างน้อย 2 บรรทัด เช่นเดิมมี 3 ใส่เผื่อไปอีก 2 เป็น 5 บรรทัด ซึ่งจะต้องหาทางลบสองบรรทัดนี้ออกจากชีต Input และ ชีต Form ในภายหลัง

การทำงานจะแบ่งเป็น 2 Code คือ Code สำหรับการวางข้อมูลและ Code สำหรับตีเส้น ให้เรียกใช้งานตามลำดับ

Code: Select all

Sub Preview()
    ' Define worksheets
    Dim WI As Worksheet
    Dim WF As Worksheet
    Dim r As Range
    Dim i As Long
    Dim blockStart As Long
    Dim blockEnd As Long
    Dim totalBlocks As Long
    Dim textContent As String
    Dim estimatedLines As Long
    Dim mergeRange As Range

    ' Improve performance
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False

    Set WI = Worksheets("Input")
    Set WF = Worksheets("Forms")
    
    ' Clear old data
    WF.Range("A12").Resize(1000, 1).EntireRow.Delete
    WF.Range("A12:AC1000").ClearContents ' Clear both values and formatting
     WF.Range("A12:AC1000").ClearFormats   ' Clear both values and formatting
     
         
    ' Start writing at row 12
    i = 12
    totalBlocks = 0

    ' Loop through cells B2 to B5
    For Each r In WI.Range("B2:B6")
        If r.Value <> "" Then
            ' รวมข้อความจาก B และ C
            textContent = r.Value & vbNewLine & r.Offset(0, 1).Value
            
            ' Define the range to be merged
            Set mergeRange = WF.Range("B" & i & ":AC" & i)
            With mergeRange
                .Merge
                .Value = textContent
                .Font.Name = "Arial Unicode MS"
                .Font.Size = 11
                .HorizontalAlignment = xlLeft
                .VerticalAlignment = xlTop
                .WrapText = True
            End With
                        
            ' ประมาณจำนวนบรรทัด
            estimatedLines = Len(textContent) \ 120 + 1 ' 80 คือจำนวนตัวอักษรต่อแถวโดยประมาณ
            WF.Rows(i).RowHeight = estimatedLines * 20 ' ปรับความสูงแถวให้เหมาะสม

            ' Calculate block range for border
            blockStart = i
            blockEnd = i + 29
                
            ' Add left border in column A (entire block)
'            With WF.Range("A" & blockStart & ":A" & blockEnd).Borders(xlEdgeLeft)
'                .LineStyle = xlContinuous
'                .Weight = xlMedium
'                .ColorIndex = 0
'            End With

            ' Add right border in column AD (entire block)
'            With WF.Range("AD" & blockStart & ":AD" & blockEnd).Borders(xlEdgeRight)
'                .LineStyle = xlContinuous
'                .Weight = xlMedium
'                .ColorIndex = 0
'            End With

            ' Add bottom border
'            With WF.Range("A" & blockEnd & ":AD" & blockEnd).Borders(xlEdgeBottom)
'                .LineStyle = xlContinuous
'                .Weight = xlMedium
'                .ColorIndex = 0
'            End With

            ' Move down 30 rows (increment 30 rows per block)
            i = i + 30
            totalBlocks = totalBlocks + 1
        End If
    Next r

    ' Restore performance settings
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
End Sub

Sub DetectStartRowOfEachPage()
    Dim ws As Worksheet
    Dim pb As HPageBreak
    Dim startRow As Integer
    Dim pageStartRows As Collection
    Dim i As Integer, j As Integer
    
    Set ws = Worksheets("Forms")
    Set pageStartRows = New Collection
    
    ' Add the first row as the start of the first page
    pageStartRows.Add 1
    
    ' Loop through each horizontal page break
    For Each pb In ws.HPageBreaks
        startRow = pb.Location.Row
        pageStartRows.Add startRow
    Next pb
    
    For i = 1 To pageStartRows.Count
        j = pageStartRows(i)
        If j > 11 Then
            With ws.Range("a11:a" & j).Borders(xlEdgeLeft)
                .LineStyle = xlContinuous
                .Weight = xlMedium
            End With
            With ws.Range("ad1:ad" & j).Borders(xlEdgeRight)
                .LineStyle = xlContinuous
                .Weight = xlMedium
            End With
            With ws.Range("ad1:ad" & j).Borders(xlEdgeRight)
                .LineStyle = xlContinuous
                .Weight = xlMedium
            End With
            With ws.Range("a" & j & ":ad" & j).Borders(xlEdgeBottom)
                .LineStyle = xlContinuous
                .Weight = xlMedium
            End With
        End If
    Next i
End Sub

[wisitsakbenz]

เรียน อาจารย์

ลอง test แล้ว มันไม่มีการตีเส้นให้ หรือผมทำอะไรผิดหรือไม่ครับ
รบกวนอาจารย์อีกครั้งครับ ขอบคุณครับ

[snasui]

ผมทดสอบแล้วได้ผลตามปกติ ไม่ทราบว่ามีวิธี Run Code อย่างไรกรุณาอธิบายมาอย่างละเอียดครับ

[wisitsakbenz]

เรียน อาจารย์ snasui

คลิกที่ Code ในส่วนของ
1.Sub Preview() แล้วกดปุ่ม Run
2. Sub DetectStartRowOfEachPage() แล้วกดปุ่ม Run ครับ
ผมทำถูกหรือไม่ครับ ขอบคุณครับ

[snasui]

ทำถูกแล้วครับ

ลอง Debug Code ตามข้อ 2 โดยรันไปทีละบรรทัดแล้วสังเกตว่ามันข้ามขั้นตอนใดไปหรือไม่ครับ

[wisitsakbenz]

เรียน อาจารย์ snasui

ทำถูกแล้วครับ
ลอง Debug Code ตามข้อ 2 โดยรันไปทีละบรรทัดแล้วสังเกตว่ามันข้ามขั้นตอนใดไปหรือไม่ครับ

ทำยังไงครับอาจารย์

[snasui]

คลิกไปที่ Code ที่ต้องการ Debug แล้วกดแป้น F8 ซ้ำ ๆ เพื่อให้รันไปทีละบรรทัด จะได้เห็นว่าบรรทัดไหนมีปัญหา การเขียน Code จำเป็นจะต้อง Debug เพื่อหาสาเหตุของปัญหาได้ครับ

[wisitsakbenz]

เรียน อาจารย์ snasui

ถึง Code นี้

Code: Select all

  If j > 11 Then

ข้ามไป End if เลยครับ ต้องแก้ไขอย่างไรครับ

[snasui]

มีการรันไปจนครบทุก Loop แล้วใช่หรือไม่ครับ

Code ส่วนนั้นจะมีการ Loop เข้าไปยังบรรทัดเริ่มของแต่ละ Page เพื่อทำการตีเส้น ตัวแปร j ตัวแรกคือบรรทัดที่ 1 ยังไม่ต้องตีเส้นจะต้องข้ามไปก่อน ไปตีเส้นบรรทัดที่มากกว่า 11 เหตุนี้มันจึงไปที่ End If เพราะยังไม่เข้าเงื่อนไข

เลข 11 มาจาก Code เดิมใช้เลข 12 เป็นบรรทัดแรกของข้อมูล ผมก็เลยใช้ 11 เพื่อให้ใกล้เคียงกัน

การกดแป้น F8 จะต้องกดไปเรื่อย ๆ จนกว่ามันจะเจอปัญหาที่แท้จริง ในการกด F8 แต่ละครั้งควรทราบว่า Code ทำงานอะไร อย่างไร ถ้าไม่เข้าใจให้ ChatGPT แปลให้ก็ย่อมได้ครับ

[wisitsakbenz]

เรียน อาจารย์

ถ้าใส่แค่ 1 ช่อง จะไม่มีการตีเส้นให้จะต้องใส่ข้อมูล หน้า input 3 ช่องถึงมีการตีเส้น และหน้าที่ 2 ไม่มีการตีเส้น

ถ้าบางครั้งมีการใส่ข้อมูลแค่ 1 ช่อง ต้องปรับ Code อย่างไรครับ ขอบคุณครับ
รบกวนอาจารย์อีกครั้งครับ ขอบคุณครับ

[snasui]

ถ้าใส่แค่ 1 ช่อง จะไม่มีการตีเส้นให้จะต้องใส่ข้อมูล หน้า input 3 ช่องถึงมีการตีเส้น และหน้าที่ 2 ไม่มีการตีเส้น

จะไม่มีการใส่แค่ 1 ช่องตามที่อธิบายไว้ดังที่ยกมาครับ

สิ่งที่จะต้องคำนึงคือการแสดง Page Break เผื่อไว้อย่างน้อย 1 หน้าเพื่อตีเส้นของหน้าสุดท้าย การทำเช่นนี้จะต้องประยุกต์โดยเพิ่มข้อมูลเผื่อในชีต Input อย่างน้อย 2 บรรทัด เช่นเดิมมี 3 ใส่เผื่อไปอีก 2 เป็น 5 บรรทัด ซึ่งจะต้องหาทางลบสองบรรทัดนี้ออกจากชีต Input และ ชีต Form ในภายหลัง

อาจจะใส่เผื่อไว้หลายบรรท้ดแล้วค่อยลบค่าที่เผื่อทิ้งในภายหลัง เนื่องจากเราจะยังไม่ทราบบรรทัดของ Page Break โดยเฉพาะ Page Break ที่ต่อจากหน้าสุดท้ายจนกว่าจะนำค่าลงไปวางครับ

[wisitsakbenz]

เรียน อาจารย์ snasui

ขอบคุณสำหรับคำแนะนำครับ