Excel VBA -- Fill Blank Cells in Excel Column

demo

Fill Blank Cells Manually        
        Some worksheets contain cells that have been left blank, in order to make the headings and subheadings easier to read.
        However, if you want to sort or filter the list, you need to fill in the blanks, by copying the value from the first filled cell above the blank.
        The following technique makes it easy to fill in the blanks.

Start by selecting the empty cells:         Select the cells in the column, starting in the row below the column heading. Choose Edit | Go To Click the Special button Select Blanks, click OK
Enter the formula to copy the value:                Type an equal sign Press the up arrow on the keyboard -- this will enter a reference to the cell above -- cell A2 in this example Hold the Ctrl key and press Enter -- this enters the formula in all selected cells
Change the formulas to values:        In order to sort or filter the data, the formulas must be changed to           values.          Select the entire column Choose Edit | Copy With the column still selected, choose Edit | Paste Special Select Values, click OK         Note: Do this carefully if there are other cells in the range           which contain formulas.

      

Fill Blank Cells Programmatically         If you frequently have to fill blank cells, you may prefer to use a macro. The following code examples will fill blank cells in the active column. Each example uses a different method to find the last row, and to fill the blank cells.         For more information on finding the last row, see Ron de Bruin's page:  Find last row, column or last cell. Ron explains the advantages and disadvantages of each method.          Fill Blank Cells Macro - Example 1         The first example, from Dave Peterson, uses a formula to fill the cells, and pastes the results as values. The code uses the .SpecialCells(xlCellTypeLastCell) method to find the last row. Sub FillColBlanks() 'by Dave Peterson  2004-01-06 'fill blank cells in column with value above 'http://www.contextures.com/xlDataEntry02.html Dim wks As Worksheet Dim rng As Range Dim LastRow As Long Dim col As Long Set wks = ActiveSheet With wks    col = activecell.column    'or    'col = .range("b1").column    Set rng = .UsedRange  'try to reset the lastcell    LastRow = .Cells.SpecialCells(xlCellTypeLastCell).Row    Set rng = Nothing    On Error Resume Next    Set rng = .Range(.Cells(2, col), .Cells(LastRow, col)) _                   .Cells.SpecialCells(xlCellTypeBlanks)    On Error GoTo 0    If rng Is Nothing Then        MsgBox "No blanks found"        Exit Sub    Else        rng.FormulaR1C1 = "=R[-1]C"    End If    'replace formulas with values    With .Cells(1, col).EntireColumn        .Value = .Value    End With End With End Sub 复制代码
Fill Blank Cells Macro - Example 2         In the following code, Rick Rothstein uses the .Find method to calculate the last row. Instead of using a formula to fill from above, each cell gets its value from the cell above the first cell of the Area that it's in, using the Offset property. Sub FillColBlanks_Offset() 'by Rick Rothstein  2009-10-24 'fill blank cells in column with value above 'http://www.contextures.com/xlDataEntry02.html   Dim Area As Range, LastRow As Long   On Error Resume Next   LastRow = Cells.Find(What:="*", SearchOrder:=xlRows, _                SearchDirection:=xlPrevious, _                LookIn:=xlFormulas).Row   For Each Area In ActiveCell.EntireColumn(1).Resize(LastRow). _                SpecialCells(xlCellTypeBlanks).Areas     Area.Value = Area(1).Offset(-1).Value   Next End Sub 复制代码
Fill Blank Cells Macro - Example 3         This example combines Dave Peterson's code (Example 1), with the special cells test from Ron de Bruin.         In Excel 2007, and earlier versions, there is a problem with special cells if there are more than 8192 different areas in the special cells range. This problem has been fixed in Excel 2010.         This code tries to count the areas, and if over the limit, it loops through the range in groups of 8000 rows. Sub FillColBlanks() 'http://www.contextures.com/xlDataEntry02.html 'by Dave Peterson  2004-01-06 'fill blank cells in column with value above '2010-10-12 incorporated Ron de Bruin's test for special cells limit 'http://www.rondebruin.nl/specialcells.htm Dim wks As Worksheet Dim rng As Range Dim rng2 As Range Dim LastRow As Long Dim col As Long Dim lRows As Long Dim lLimit As Long Dim lCount As Long On Error Resume Next lRows = 2 'starting row lLimit = 8000 Set wks = ActiveSheet With wks    col = ActiveCell.Column    Set rng = .UsedRange  'try to reset the lastcell    LastRow = .Cells.SpecialCells(xlCellTypeLastCell).Row    Set rng = Nothing         lCount = .Columns(col).SpecialCells(xlCellTypeBlanks).Areas(1).Cells.Count         If lCount = 0 Then         MsgBox "No blanks found in selected column"         Exit Sub     ElseIf lCount = .Columns(col).Cells.Count Then         MsgBox "Over the Special Cells Limit" 'this line can be deleted         Do While lRows < LastRow             Set rng = .Range(.Cells(lRows, col), .Cells(lRows + lLimit, col)) _                            .Cells.SpecialCells(xlCellTypeBlanks)             rng.FormulaR1C1 = "=R[-1]C"             lRows = lRows + lLimit         Loop     Else         Set rng = .Range(.Cells(2, col), .Cells(LastRow, col)) _                        .Cells.SpecialCells(xlCellTypeBlanks)         rng.FormulaR1C1 = "=R[-1]C"     End If    'replace formulas with values    With .Cells(1, col).EntireColumn        .Value = .Value    End With End With End Sub 复制代码

http://www.contextures.com/xlDataEntry02.html

demo

This is my total code to do this, including open file and save the Excel file in a new file name.


'Description: There is a grouped Excel sheet. we need to fill all the empty cells under customer name with the real name listed at the top cell, and, after finish it, save it to a new Excel file. with file name distinctive to the originals.

Sub BlankProcess()
    'Code by: John Zhang
    'Date: August 27, 2012
    Dim strFile As String, repcode As Integer
    Dim myList, myCell, myGet, i
    i = 1
   
    repcode = 0
    With Application
        .DefaultFilePath = "\\sales-server\e$\InvShare\SpecialItems"
        'ChDrive ("\\sales-server")
        ChDir ("\\sales-server\e$\InvShare\SpecialItems")
        strFile = .GetOpenFilename("Excel files (*.xls), *.xls*," & _
                                          "CSV files (*.csv)  , *.csv," & _
                                          "All files (*.*)    , *.*", 1, "Open Item File", "", False)
    End With
    If strFile <> "False" Then
       Workbooks.Open strFile
       If Len(strFile) > 1 Then
          repcode = MsgBox("You openned file " & strFile & ".", vbOKOnly, "Notice")
       Else
          MsgBox "Nothing to be done with empty command."
       End If
       'strFile =
       If ActiveSheet.Parent.FullName = strFile Then
           MsgBox "Data processed here ..."
       End If
       'ActiveSheet.Range("D9 : D65530").Select
       'myList = ActiveSheet.Range("D9 : D65535").Select
       ActiveSheet.Range("D9 : D65535").Select
       myGet = Empty
       i = 0
       For Each myCell In Selection
           'myCell.Value = "i"
           'Windows("PERSONAL").Activate
           If myCell.Column = 4 Then 'Because we have merged cells, so we just need to check the specific column every row
           If myCell = Empty Then
              If myCell.Offset(0, 2) = Empty Then
                 Save_As ""
                 Exit Sub ' to make sure it stops when table ended.
              End If
              i = i + 1
              myCell.Value = myGet
           Else
              myGet = myCell.Value
              i = 0
           End If
           'Sheets("Sheet1").Cells(i, 1).Value = myCell.Value
           'Windows("Book1").Activate
           i = i + 1
           End If
       Next
       ActiveSheet.Select
    Else: Exit Sub
    End If
    ChDrive (Left(Application.DefaultFilePath, 1))
    ChDir (Application.DefaultFilePath)

End Sub

Sub Save_As(strName As String)
' sub program
' Name: Save_As
'strName -- the file name to be saved as

'
    'Code by: John Zhang
    'Date: August 27, 2012
    Dim xFile, strNewFile, strFileName As String
    Dim cnt1, cnt2 As Integer
    xFile = strNewFile = strFileName = ""
    If strName = Empty Then
       strName = ActiveWorkbook.FullName
    End If
    cnt1 = InStr(1, strName, ".", vbTextCompare)
    If cnt1 > 0 Then
       xFile = Right(strName, Len(strName) - cnt1)
       strFileName = Left(strName, cnt1 - 1)
    Else
       strFileName = strName
    End If
    strNewFile = strFileName & "(Name Filled)." & xFile
    MsgBox "Active sheet is """ & ActiveSheet.Name & """ in " & vbCrLf & _
       ActiveWorkbook.FullName
    ActiveWorkbook.SaveAs Filename:= _
        strNewFile _
        , FileFormat:=xlExcel8, Password:="", WriteResPassword:="", _
        ReadOnlyRecommended:=False, CreateBackup:=False
End Sub