Search code examples
excelvba

Look-up range with dynamic numbers of headers, where if header is applicable, to copy whole column and append


The objective is to create a mailing list table, each e-mail per cell.

My code cuts between sheets so it's more user-friendly hopefully.
There will also be a IF code for each "If Applicable" cell in the actual worksheet. As such, in Sheet 2 column K-N, the header could be there, or show "" instead (and hence unable to fit look-up).

The code runs for K = 11 for Header 1 to 3 for now. As cell "K7" skips to Header 6, which makes more intuitive sense to the user on the sequencing of Headers, it however seems to cause the code to not recognise and end there.
If I replace cell "K7" with Header 4, it will work.
I prefer to fix the code than mess with user-intuitive use.

How could I continue to search for Headers 4-last Header for each cell?

Sheet1 'Mail List'

Header 1 Header 2 Header 3 Header 4 Header 5 Header 6 Header 7 Header 8 Header 9 Header 10 Header 11 Header 12 Header 13 Header 14
[email protected] [email protected] [email protected] [email protected] .. .. .. .. .. .. .. .. .. ..
[email protected] [email protected] [email protected] [email protected]
[email protected] [email protected] .. .. .. .. .. .. ..
..

Sheet2 'Build'

Loadport ETA Notices for A Loadport ETA Notices for B Disport ETA Notices for C Disport ETA Notices for D Loadport ETA Notices for A Loadport ETA Notices for B Disport ETA Notices for C Disport ETA Notices for D
build area build area Fixed Text Value but will not match Headers so should be left alone build area Header 1 Header 1 Fixed Text Value but will not match Headers so should be left alone Header 1
build area Header 2 (if applicable) Header 4 (if applicable) Header 1 Header 12
Header 3 (if applicable) Header 5 (if applicable) ..11
Header 6 (if applicable) Header 9 (if applicable)
Header 7 (if applicable) Header 10 (if applicable)
Header 8 (if applicable)
Header 9 (if applicable)
Header 10 (if applicable)
Sub GetEmailAddressETA()

    Dim i As Integer, j As Integer
    Dim lastColumnETA As Long, lastRowETA As Long
    Dim ETAeach As Range
    
    Dim k As Integer
    
    Dim cCell As Range
    Dim lCell As Range
    
    Set sh1 = Sheets("MailList")
    Set sh2 = Sheets("Build")
    
    Dim lastRowL As Long, lastBuildL As Long
    Dim lrg As Range, ETArng As Range
    
    sh1.Select
    lastColumnETA = sh1.Cells(1, Columns.Count).End(xlToLeft).Column
    
    For j = 1 To lastColumnETA 'Intended to be dynamic for future-proofing
        Set cCell = sh1.Cells(1, j) 'Intended for each header in 'MailList' to be a criteria cell
        lastRowETA = sh1.Cells(sh1.Rows.Count, j).End(xlUp).Row 'For each header to have dynamic last row
        Set ETArng = sh1.Range(sh1.Cells(2, j), sh1.Cells(lastRowETA, j))  'Set range to copy if later found applicable
        
        sh2.Select 'change sheet
        For k = 11 To 11 'ideally, will be k = 11 to 14 representing column K-N
        
        lastRowL = sh2.Cells(sh2.Rows.Count, k).End(xlUp).Row   'for dynamic last row in look-up
        Set lrg = sh2.Range(Cells(4, k), Cells(lastRowL, k))  'set look-up range with dynamic range
        
            For Each lCell In lrg.Cells

                If cCell.Value = lCell.Value Then 'if cell matches sh1's Header

                    lastBuildL = sh2.Cells(sh2.Rows.Count, k - 9).End(xlUp).Row 'look for last filled row in column B
                    ETArng.Copy
                    Range(Cells(lastBuildL + 1, k - 9), Cells(lastBuildL + 1, k - 9)).PasteSpecial Paste:=xlPasteValues 'paste sh1 range for applicable header, into column B

                    Exit For
                    
                End If
            Next lCell

        Next k
            
    Next j
    
End Sub

Expected Output, where ..(number) = email address in specified header:

Loadport ETA Notices for A Loadport ETA Notices for B Disport ETA Notices for C Disport ETA Notices for D Loadport ETA Notices for A Loadport ETA Notices for B Disport ETA Notices for C Disport ETA Notices for D
[email protected] [email protected] Fixed Text Value but will not match Headers so should be left alone [email protected] Header 1 Header 1 Fixed Text Value but will not match Headers so should be left alone Header 1
[email protected] [email protected] [email protected] [email protected] Header 2 (if applicable) Header 4 (if applicable) Header 1 Header 12
[email protected] [email protected] [email protected] [email protected] Header 3 (if applicable) Header 5 (if applicable) Header 11
[email protected] [email protected] [email protected] Header ..1212 Header 6 (if applicable) Header 9 (if applicable)
[email protected] [email protected] Header ..1111 Header 7 (if applicable) Header 10 (if applicable)
..77 ..55 Header 8 (if applicable)
..77 ..55 Header 9 (if applicable)
..77 ..55 Header 10 (if applicable)
..88 ..55
..88
..88

Solution

  • I did something really stupid. My code is actually already completed as per upload. My headers just weren't aligned because I was creating a formula conditional that made me miss it out.

    Just wanted to answer my own question to ensure anyone stumbling across this code can use as-is. Happy to hear if any further optimisation to the code can be done.