Excel Forum

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

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

Code: Select all

if r <> "" Then

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

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

Code: Select all

  If j > 11 Then