Snasui Excel Forum

อ่อค่ะอาจารย์

:thup: Code ได้ตรงกับที่ต้องการค่ะ ขอบคุณอาจารย์มากค่ะ ให้ความรู้ความช่วยเหลือสามารถแก้ปัญหาได้ตลอดมาค่ะ

Sub FillBlanks()
    Dim rAll As Range
    On Error Resume Next
    Set rAll = Worksheets(1).UsedRange.SpecialCells(xlCellTypeBlanks)
    rAll.Formula = "=R[1]C"
    rAll.CurrentRegion.Value = rAll.CurrentRegion.Value
    MsgBox "Finished.", vbInformation
End Sub[/c]

:lol: แบบนั้นไม่เรียกว่าเติมค่าให้เหมือนด้านบน แต่เป็นการเติมค่าให้เหมือนด้านล่าง จะนำ Code มาใช้ตรง ๆ ไม่ได้ครับ

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

[code]Sub FillBlanks()
Dim rAll As Range
On Error Resume Next
Set rAll = Worksheets(1).UsedRange.SpecialCells(xlCellTypeBlanks)
rAll.Formula = "=R[1]C"
rAll.CurrentRegion.Value = rAll.CurrentRegion.Value
MsgBox "Finished.", vbInformation
End Sub[/c]

:thup: ขอบคุณคุณ puriwutpokin มาก ๆ ค่ะ Code ได้ตรงตามที่ต้องการเลยค่ะ

Sub FillBlanks()
On Error Resume Next
With ActiveSheet
  For i = .Range("d" & .Rows.Count).End(xlUp).Row To 1 Step -1
          If .Cells(i, 5).Value = "" Then
              .Cells(i, 5).Resize(, 12).Value = .Cells(i, 5).Offset(1).Resize(, 12).Value
        End If
    Next
End With
MsgBox "Finished.", vbInformation
End Sub

[quote=suka post_id=91189 time=1552974317 user_id=562]
เรียนอาจารย์ และ ทุกท่านช่วยเรื่องปรับโค้ดค่ะ

จากตัวอย่างไฟล์แนบต้องการให้โค้ดเติมช่องว่างขึ้นข้างบนให้ครบจำนวนตามค่าในเซลล์ E ที่ระบายสีเขียวไว้ค่ะ
ตามตัวอย่าง Code ข้างล่างนี้ต้องการปรับให้ Resize ตามค่าในเซลล์ E3,E6,E20 เติมช่องว่างให้ครบตามที่ระบายสีเหลืองในไฟล์แนบค่ะ

ติดปัญหาจากการ RunCode ได้ตามตัวอย่างชีทที่ระบายสีแดงค่ะ

ชีทที่ระบาบสีเขียวเป็นชีทที่ต้องการให้ Code เติมช่องว่างให้ค่ะ

หมายเหตุ : โค้ดจากคลิปไลฟ์สดค่ะ https://www.facebook.com/santipong.nasui/videos/2587461247934717?sfns=mo

[code]Sub FillBlanks()
Dim r As Range
Dim sh As Worksheet
On Error Resume Next
For Each sh In Worksheets
For Each r In sh.UsedRange. _
SpecialCells(xlCellTypeBlanks)
r.Value = r.Offset(1, 0).Value
Next r
Next sh
MsgBox "Finished.", vbInformation
End Sub[/code]
[/quote]

ลองปรับเป็น :D
[code]Sub FillBlanks()
On Error Resume Next
With ActiveSheet
For i = .Range("d" & .Rows.Count).End(xlUp).Row To 1 Step -1
If .Cells(i, 5).Value = "" Then
.Cells(i, 5).Resize(, 12).Value = .Cells(i, 5).Offset(1).Resize(, 12).Value
End If
Next
End With
MsgBox "Finished.", vbInformation
End Sub[/code]

Sub FillBlanks()
     Dim r As Range
     Dim sh As Worksheet
     On Error Resume Next
     For Each sh In Worksheets
         For Each r In sh.UsedRange. _
                 SpecialCells(xlCellTypeBlanks)
            r.Value = r.Offset(1, 0).Value
         Next r
    Next sh
    MsgBox "Finished.", vbInformation
End Sub

เรียนอาจารย์ และ ทุกท่านช่วยเรื่องปรับโค้ดค่ะ

จากตัวอย่างไฟล์แนบต้องการให้โค้ดเติมช่องว่างขึ้นข้างบนให้ครบจำนวนตามค่าในเซลล์ E ที่ระบายสีเขียวไว้ค่ะ
ตามตัวอย่าง Code ข้างล่างนี้ต้องการปรับให้ Resize ตามค่าในเซลล์ E3,E6,E20 เติมช่องว่างให้ครบตามที่ระบายสีเหลืองในไฟล์แนบค่ะ

ติดปัญหาจากการ RunCode ได้ตามตัวอย่างชีทที่ระบายสีแดงค่ะ

ชีทที่ระบาบสีเขียวเป็นชีทที่ต้องการให้ Code เติมช่องว่างให้ค่ะ

หมายเหตุ : โค้ดจากคลิปไลฟ์สดค่ะ https://www.facebook.com/santipong.nasui/videos/2587461247934717?sfns=mo

[code]Sub FillBlanks()
Dim r As Range
Dim sh As Worksheet
On Error Resume Next
For Each sh In Worksheets
For Each r In sh.UsedRange. _
SpecialCells(xlCellTypeBlanks)
r.Value = r.Offset(1, 0).Value
Next r
Next sh
MsgBox "Finished.", vbInformation
End Sub[/code]