Copy corresponding Cell data into blank cells after applying Auto Filter in a Macro

Hi,

I've applied an auto filter using a macro that currently filters my data on blank cells and then fills the blank cells using todays date. This works great.

I now want to run the same macro, only instead of inserting todays date in the cell thats blank I want to insert the corresponding value from another row / cell.

The number of rows in the spreadsheet(s) will always vary.
The Column where the data is to be copied from is "D".
and the Column being filtered on is currently "H"

Sub Fill_Date()
Range("H:H").Select
Dim rng1 As Range
On Error Resume Next
Set rng1 = Selection.SpecialCells(xlBlanks)
On Error GoTo 0
If Not rng1 Is Nothing Then rng1.Value = Format(Now(), "dd-mmm-yy")
End Sub

I've played about with offset and recorded a macro but for the life of me can't get it to work.... any ideas?

Cheers

How about:

Sub Fill_Date()
Dim Cl
For Each Cl In Range("H:H").SpecialCells(xlBlanks).Cells
    Cl.Value = Range("D" & Cl.Row).Value
Next
End Sub

Cheers yudlugar.... that worked a treat

okay - so i might have been a bit over eager in marking this one as solved.

It works fine on one sheet - I have 2 issues with that i cant seem to solve..

1) I'm looking for a wee error handler that will let it bypass a sheet if there are no blank cells - seems not to like this
2) I'm going to run this as a call procedure on multiple sheets so need to be able to do that... is there an easy way to add in appropriate worksheet references for unlimited worksheets?

Hope i'm making sense..

Here's the code I'm running just now so you can see where I'm going with this if it helps...

Sub Perform_Data_Cleanup()
Dim ws As Worksheet

    Application.DisplayAlerts = False
    Application.ScreenUpdating = False

    For Each ws In ThisWorkbook.Worksheets

        If ws.Name <> "Control" Then

            Call Text_to_Column_Comma(ws)   'run text to columns macro on all worksheets (Comma)
            Call DeleteColumnF(ws)          'run delete columnf macro on all worksheets
            Call copy_subject_Column(ws)    'run copy subject column macro on all worksheets
            Call Replace_Re_Fw(ws)          'run remove RE: and FW: from column G on all worksheets
            'Call Text_to_Column_dash(ws)    'run text to columns macro on all worksheets (Dash)
            Call Fill_Date(ws)

        End If

    Next ws

    Application.DisplayAlerts = False
    Application.ScreenUpdating = True
End Sub


Sub Text_to_Column_Comma(sh As Worksheet)
'
' Text_Columns1 Macro
' Macro to separate Text to Columns where the delimiter is ,
'

    sh.Columns("A:A").TextToColumns Destination:=sh.Range("A1"), DataType:=xlDelimited, _
                                    TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
                                    Semicolon:=False, Comma:=True, Space:=False, Other:=False, OtherChar:=",", _
                                    FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, _
        4), Array(6, 1), Array(7, 1), Array(8, 1), Array(9, 1)), TrailingMinusNumbers:=True

End Sub


Sub DeleteColumnF(wrk As Worksheet)
'
' DeleteColumnF Macro

    wrk.Columns("F:F").Delete Shift:=xlToLeft

End Sub


Sub copy_subject_Column(ASheet As Worksheet)

    ASheet.Range("D:D").Copy
    ASheet.Range("H1").PasteSpecial Paste:=xlPasteValues
    ASheet.Columns("D:D").Delete Shift:=xlToLeft
    
End Sub


Sub Text_to_Column_dash(ws As Worksheet)
'
' Text_Columns1 Macro on Asterisk
' Macro to separate Text to Columns where the delimiter is -
'
    ws.Columns("G:G").TextToColumns Destination:=ws.Range("G1"), DataType:=xlDelimited, _
                                    TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
                                    Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar:="-", _
                                    FieldInfo:=Array(1, 1), TrailingMinusNumbers:=True

End Sub


Sub Replace_Re_Fw(ws As Worksheet)

        ws.Cells.Replace What:="Re: ", Replacement:="", LookAt:= _
        xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
         ws.Cells.Replace What:="Fw: ", Replacement:="", LookAt:= _
        xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False

End Sub
Sub Fill_Date(ASheet As Worksheet)
Dim Cl
For Each Cl In ASheet.Range("G:G").SpecialCells(xlBlanks).ASheet.Cells
    Cl.Value = ASheet.Range("D" & Cl.Row).Value
    On Error GoTo 0
Next
End Sub
Sub Separate_Subject()
'
' Separates the Subject Column into two columns, before **MIDART" and after **MIDART**
'

    Range("I1").Select
    ActiveCell.FormulaR1C1 = "Left Subject"
    Range("I2").Select
    ActiveCell.FormulaR1C1 = _
        "=IF(ISERROR(FIND(""**MIDART**"",RC[-1])),RC[-1],LEFT(RC[-1],FIND(""**MIDART**"",RC[-1])-1))"
    Range("I2").Select
    ActiveCell.AutoFill Destination:=Range(ActiveCell.Offset(0, -1), ActiveCell.Offset(0, -1).End(xlDown)).Offset(0, 1)
    Range("J1").Select
    ActiveCell.FormulaR1C1 = "Right Subject"
    Range("J2").Select
    ActiveCell.FormulaR1C1 = _
        "=IF(ISERROR(FIND(""**MIDART**"",RC[-2])),RIGHT(RC[-2],LEN(RC[-2])-FIND(""**MIDART**"",RC[-2])))"
    Range("J2").Select
    ActiveCell.FormulaR1C1 = _
        "=IF(ISERROR(FIND(""**MIDART**"",RC[-2])),"""",RIGHT(RC[-2],LEN(RC[-2])-FIND(""**MIDART**"",RC[-2])))"
    Range("J2").Select
     ActiveCell.AutoFill Destination:=Range(ActiveCell.Offset(0, -1), ActiveCell.Offset(0, -1).End(xlDown)).Offset(0, 1)
End Sub

Sub Fill_Date(ASheet As Worksheet)
Dim Cl
On Error GoTo no_cells_found
For Each Cl In ASheet.Range("G:G").SpecialCells(xlBlanks).Cells
    Cl.Value = ASheet.Range("D" & Cl.Row).Value
Next
On Error GoTo 0
no_cells_found:
End Sub