snasui.com ยินดีต้อนรับ ยินดีต้อนรับสู่กระดานถามตอบ Excel and VBA และอื่น ๆ ที่เป็นมิตรกับทุกท่าน มีไฟล์แนบมหาศาล ช่วยให้ท่านค้นหาและติดตามศึกษาได้โดยง่าย สมาชิกท่านใดที่ยังไม่ได้ระบุ Version ของ Excel ที่ใช้งานจริง สามารถทำตาม Link นี้เพื่อจะได้รับคำตอบที่ตรงกับ Version ของท่านครับ ระบุ Version ของ Excel
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
You do not have the required permissions to view the files attached to this post.
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
You do not have the required permissions to view the files attached to this post.
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
You do not have the required permissions to view the files attached to this post.
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
snasui.com ยินดีต้อนรับ 
สมาชิกท่านใดที่ยังไม่ได้ระบุ Version ของ Excel ที่ใช้งานจริง สามารถทำตาม Link นี้เพื่อจะได้รับคำตอบที่ตรงกับ Version ของท่านครับ 
โปรดทราบ 
มีการรันไปจนครบทุก Loop แล้วใช่หรือไม่ครับ