If cell A is empty but cell F is not then copy data A to E from above in A to E in empty spots?

[Sjon1974]

I am making a file that imports a .CSV en copy relative data to other sheet. (with a lot of help from Fluff

Private Sub CMB1_Click()
  Dim ws As Worksheet, strFile As String
Worksheets("Import").Range("A1:BH250").Clear
Set ws = ActiveWorkbook.Sheets("Import") 'set to current worksheet name
strFile = Application.GetOpenFilename("CSV File (*.csv),*.csv", , "Please select text file...")
With ws.QueryTables.Add(Connection:="TEXT;" & strFile, Destination:=ws.Range("A1"))
     .TextFileParseType = xlDelimited
     .TextFileCommaDelimiter = True
     .Refresh
End With

   Dim ws1 As Worksheet, ws2 As Worksheet
   Dim lastRow As Long
   Dim Cl As Range
    Set ws1 = ThisWorkbook.Sheets("Import")
   Set ws2 = ThisWorkbook.Sheets("Database")
   lastRow = ws2.Cells(Rows.Count, "A").End(xlUp).Row
   ws1.Range("A7").AutoFilter 1, "IM*"
   ws1.AutoFilter.Range.Offset(1).EntireRow.Copy ws2.Range("a" & lastRow + 1)
   ws1.AutoFilterMode = False
   Call deleteBlankRows
End Sub

But before i filter and copy i want to check and fill empty cells (see foto)

If cell A is empty but cell F is not then copy data A to E from above in A to E in empty spots?

I have been trying the following script but i cannot get it to work

Sub FillColBlanks_Offset()
  Dim ws1 As Worksheet
       Set ws1 = ThisWorkbook.Sheets("Import")
'by Rick Rothstein  2009-10-24
'fill blank cells in column with value above
'https://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

 

[Sjon1974]

I made it happen, al is it maybe a overkill. I made it happen that Column A was working so i copied it 5 times for the other columns

Private Sub CMB1_Click()
  Dim ws As Worksheet, strFile As String
Worksheets("Import").Range("A1:BH250").Clear
Set ws = ActiveWorkbook.Sheets("Import") 'set to current worksheet name
strFile = Application.GetOpenFilename("CSV File (*.csv),*.csv", , "Please select text file...")
With ws.QueryTables.Add(Connection:="TEXT;" & strFile, Destination:=ws.Range("A1"))
     .TextFileParseType = xlDelimited
     .TextFileCommaDelimiter = True
     .Refresh
End With
Call FillColBlanks
End Sub
Sub FillColBlanks()
Dim wks As Worksheet
Dim rng As Range
Dim LastRow As Long
Dim col As Long
Set wks = ThisWorkbook.Sheets("import")
With wks
    col = .Range("A1").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(5, 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
Call FillColBlanks2
End Sub
Sub FillColBlanks2()
Dim wks As Worksheet
Dim rng As Range
Dim LastRow As Long
Dim col As Long
Set wks = ThisWorkbook.Sheets("import")
With wks
    col = .Range("B1").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(5, 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
Call FillColBlanks3
End Sub
Sub FillColBlanks3()
Dim wks As Worksheet
Dim rng As Range
Dim LastRow As Long
Dim col As Long
Set wks = ThisWorkbook.Sheets("import")
With wks
    col = .Range("C1").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(5, 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
Call FillColBlanks4
End Sub
Sub FillColBlanks4()
Dim wks As Worksheet
Dim rng As Range
Dim LastRow As Long
Dim col As Long
Set wks = ThisWorkbook.Sheets("import")
With wks
    col = .Range("D1").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(5, 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
Call FillColBlanks5
End Sub
Sub FillColBlanks5()
Dim wks As Worksheet
Dim rng As Range
Dim LastRow As Long
Dim col As Long
Set wks = ThisWorkbook.Sheets("import")
With wks
    col = .Range("E1").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(5, 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
Call Import
End Sub
Sub Import()
   Dim ws1 As Worksheet, ws2 As Worksheet
   Dim LastRow As Long
   Dim Cl As Range
    Set ws1 = ThisWorkbook.Sheets("Import")
   Set ws2 = ThisWorkbook.Sheets("Database")
   LastRow = ws2.Cells(Rows.Count, "A").End(xlUp).Row
   ws1.Range("A7").AutoFilter 1, "IM*"
   ws1.AutoFilter.Range.Offset(1).EntireRow.Copy ws2.Range("a" & LastRow + 1)
   ws1.AutoFilterMode = False
   Call deleteBlankRows
End Sub
Sub deleteBlankRows()
   Dim ws1 As Worksheet, ws2 As Worksheet
   Dim LastRow As Long
   Dim Cl As Range
   Set ws2 = ThisWorkbook.Sheets("Database")
Application.ScreenUpdating = False
ws2.Columns("G:G").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Application.ScreenUpdating = True
End Sub