• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

Combine header list macros and FillColBlanks Macro into one

T

Tim Hanson

Member
Is it possible to combine these into one Macro

The 1st sub acts on columns by a array of header names

I have to run the 2nd sub on numerous non-contiguous columns so I am calling it up the 10 different times.

I would like to combine the first sub with the second so as to run the 2nd sub by a list of header names.

I have tried combing them but have had no success, can't get how to use the"colToFormat" of the 1st sub in the 2nd sub.

Thanks

Code: 
Sub fmt()
    ColList = "Field1,Field2,Field3,Field4"
    colarray = Split(ColList, ",")
    Set colToFormat = Nothing
    For Each heading In colarray
    Set headingFound = Range("A:A").Offset(0, ActiveSheet.Cells.Find(What:=heading, After:=ActiveCell, LookIn:=xlFormulas, _
        LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False).Column - 2)
 
 
      If colToFormat Is Nothing Then Set colToFormat = headingFound Else Set colToFormat = Union(colToFormat, headingFound)
    Next
    MsgBox colToFormat.Address
 
End Sub

Code: 
Sub FillColBlanks(sColRange As String)
 
'by Dave Peterson  2004-01-06
'fill blank cells in column with value above
Dim wks As Worksheet
Dim rng As Range
Dim Lastrow As Long
Dim col As Long
 
Set wks = ActiveSheet
With wks
 
  col = .Range(sColRange As String).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
 
Hi, Tim Hanson!

Not fully checked but maybe it's a good starting point:
Code: 
Option Explicit

Sub fmt_FillColBlanks()
    ' constants
    Const ColList = "Field1,Field2,Field3,Field4"
    ' declarations
    Dim ColArray As Variant, Heading As Variant
    Dim ColToFormat As Range, HeadingFound As Range, rng As Range
    Dim LastRow As Long, Col As Integer
    Dim I As Integer
    ' start
    ColArray = Split(ColList, ",")
    Set ColToFormat = Nothing
    ' process
    '  define columns
    For Each Heading In ColArray
        Set HeadingFound = Range("A:A").Offset(0, ActiveSheet.Cells.Find( _
            What:=Heading, After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart, _
            SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
            ).Column - 2)
        If Not HeadingFound Is Nothing Then
            If ColToFormat Is Nothing Then
                Set ColToFormat = HeadingFound
            Else
                Set ColToFormat = Union(ColToFormat, HeadingFound)
            End If
        End If
    Next Heading
    '  set rows
    LastRow = ActiveSheet.UsedRange.Rows.Count
    '  fill blanks
    With ColToFormat
        For I = 1 To .Columns.Count
            Set rng = Range(.Cells(2, I), .Cells(LastRow, I)).Cells.SpecialCells(xlCellTypeBlanks)
            If Not rng Is Nothing Then
                rng.FormulaR1C1 = "=R[-1]C"
                rng.EntireColumn.Value = rng.EntireColumn.Value
            End If
        Next I
    End With
    ' end
    MsgBox ColToFormat.Address
 End Sub

Just advise if any issue.

Regards!
 
Hello SirJB7 thank you for your response,

I get a run time error 1004: "No cells were found"
Although there are cells to copy down. the headers are in the first row and are not copied down the cells to copy down start in row 2 if this helps

This line is highlighted in yellow
" Set rng = Range(.Cells(2, I), .Cells(LastRow, I)).Cells.SpecialCells(xlCellTypeBlanks)"

Not sure what other information to give you that might help.

Thanks
 
Hi, Tim Hanson!
Any chance uploading a sample file? I'm lazy at this time in the night.
Regards!
 
Hi, Tim Hanson!

A few tweaks required: columns select shifted by 1, if no blank cells crashed, entire column repeated same column for each area of it making it very slow, and didn't handle ranges of non adjacent columns so Areas object got required.

Here's the code:
Code: 
Option Explicit

Sub fmt_FillColBlanks()
    ' constants
    Const ColList = "email,attribute_3,attribute_2"
    ' declarations
    Dim ColArray As Variant, Heading As Variant
    Dim ColToFormat As Range, HeadingFound As Range, rng As Range
    Dim LastRow As Long, Col As Integer
    Dim I As Integer, J As Integer
    ' start
    ColArray = Split(ColList, ",")
    Set ColToFormat = Nothing
    ' process
    '  define columns
    For Each Heading In ColArray
        Set HeadingFound = Range("A:A").Offset(0, ActiveSheet.Cells.Find( _
            What:=Heading, After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart, _
            SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
            ).Column - 1)
        If Not HeadingFound Is Nothing Then
            If ColToFormat Is Nothing Then
                Set ColToFormat = HeadingFound
            Else
                Set ColToFormat = Union(ColToFormat, HeadingFound)
            End If
        End If
    Next Heading
    '  set rows
    LastRow = ActiveSheet.UsedRange.Rows.Count
    '  fill blanks
    With ColToFormat
        For I = 1 To .Areas.Count
            For J = 1 To .Areas(I).Columns.Count
                On Error Resume Next
                Set rng = Nothing
                Set rng = Range(.Areas(I).Cells(2, J), _
                    .Areas(I).Cells(LastRow, J)).SpecialCells(xlCellTypeBlanks)
                On Error GoTo 0
                If Not rng Is Nothing Then
                    rng.FormulaR1C1 = "=R[-1]C"
                    rng.Value = rng.Value
                End If
            Next J
        Next I
    End With
    ' end
    MsgBox ColToFormat.Address
 End Sub

Regards!
 
SirJB7, thanks again, almost working I am getting

Code: 
Robert Johnson
Robert Johnson
Robert Johnson
Robert Johnson
Robert Johnson
Robert Johnson
Robert Johnson
James Hanson
Robert Johnson
Robert Johnson
Robert Johnson
Robert Johnson
Robert Johnson

should be

Code: 
Robert Johnson
Robert Johnson
Robert Johnson
Robert Johnson
Robert Johnson
Robert Johnson
Robert Johnson
Robert Johnson
James Hanson
James Hanson
James Hanson
James Hanson
James Hanson
James Hanson
James Hanson

Thanks
 
I believe the following replicates your 2 processes.

Code: 
Option Explicit
Option Base 1
Sub testo()
Dim ar As Variant
Dim i As Variant
Dim j As Long
Dim lr As Long
 
ar = Array("attribute_3", "attribute_2") ' Add more to suit
lr = Range("A" & Rows.Count).End(3).Row
 
On Error Resume Next
    For i = 1 To UBound(ar)
        j = Rows(1).Find(ar(i)).Column
        Range(Cells(2, j), Cells(lr, j)).SpecialCells(4).Formula = "=R[-1]C"
        Range(Cells(2, j), Cells(lr, j)).Value = Range(Cells(2, j), Cells(lr, j)).Value
    Next i
 
On Error GoTo 0
End Sub

I will add a file to prove workings later today if you can not get it going but should go fine on your test file.

Take care

Smallman
 
Smallman thank you, I have tried your code but it only works for the first column encountered that is listed header in the array
 
I have it working on all columns. I have added many additional columns and it goes like thunder. I will post a file this evening and I will not change one letter in my code and the code will roll really nicely.

Mmm what version of XL are you on. I am using XL 10.

Take care

Smallman
 
With the greateset of luck the file will attach. I have not been able to achieve file attachments away from my home computer.

EDIT

Bingo - uploaded a file - notice how the code runs to all columns.
 

Attachments

  • FixData.xlsm
    23.3 KB · Views: 4
Hi, Tim Hanson!

Fixed, used 2 ranges, one for filling, another for copying values:
Code: 
Option Explicit

Sub fmt_FillColBlanks()
    ' constants
    Const ColList = "email,attribute_3,attribute_2"
    ' declarations
    Dim ColArray As Variant, Heading As Variant
    Dim ColToFormat As Range, HeadingFound As Range, rng1 As Range, rng2 As Range
    Dim LastRow As Long, Col As Integer
    Dim I As Integer, J As Integer
    ' start
    ColArray = Split(ColList, ",")
    Set ColToFormat = Nothing
    ' process
    '  define columns
    For Each Heading In ColArray
        Set HeadingFound = Range("A:A").Offset(0, ActiveSheet.Cells.Find( _
            What:=Heading, After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart, _
            SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
            ).Column - 1)
        If Not HeadingFound Is Nothing Then
            If ColToFormat Is Nothing Then
                Set ColToFormat = HeadingFound
            Else
                Set ColToFormat = Union(ColToFormat, HeadingFound)
            End If
        End If
    Next Heading
    '  set rows
    LastRow = ActiveSheet.UsedRange.Rows.Count
    '  fill blanks
    With ColToFormat
        For I = 1 To .Areas.Count
            For J = 1 To .Areas(I).Columns.Count
                Set rng1 = Range(.Areas(I).Cells(2, J), .Areas(I).Cells(LastRow, J))
                On Error Resume Next
                Set rng2 = Nothing
                Set rng2 = rng1.SpecialCells(xlCellTypeBlanks)
                On Error GoTo 0
                If Not rng2 Is Nothing Then
                    rng2.FormulaR1C1 = "=R[-1]C"
                    rng1.Copy
                    rng1.PasteSpecial Paste:=xlPasteValues
                End If
            Next J
        Next I
    End With
    ' end
    [a1].Select
    Application.CutCopyMode = xlCopy
    Set rng2 = Nothing
    Set rng1 = Nothing
    MsgBox ColToFormat.Address
 End Sub

Regards!
 
Hi, Tim Hanson!
Glad you solved it. Thanks for your feedback and for your kind words too. And welcome back whenever needed or wanted.
Regards!
 
SirJB7 this fixed the issue.

Change:
'replace formulas with values
rng.Value = rng.Value
to
'replace formulas with values
With .Cells(1, Col).EntireColumn
.Value = .Value
End With

Thank you both again!!
 
Hi, Tim Hanson!
A few tweaks required: columns select shifted by 1, if no blank cells crashed, entire column repeated same column for each area of it making it very slow, and didn't handle ranges of non adjacent columns so Areas object got required.
Click to expand...
But in that way you're changing (copying formulas & pasting values) a million times by column, instead of the number just required.
Regards!
 
You must log in or register to reply here.
Back
Top