Code VBA เติมช่องว่างค่ะ

[suka]

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

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

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

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

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

Code: Select all

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

[puriwutpokin]

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

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

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

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

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

Code: Select all

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: Select all

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

[suka]

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

[snasui]

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

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

Code: Select all

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]

[suka]

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

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