VBA to retrieve a value from the next non-blank cell in the same column, if cell in another column is non-blank

[curtishavak]

I have a set of contact data that has been extracted from our CRM system and needs to be imported into our ESP for marketing purposes. The two systems can't talk directly to one another. I have extracted the data necessary, but it is formatted in a way that will not allow direct import.

The data is laid out in a horizontal hierarchy: Party -> Site -> Individual Contact. I've included a link to a sample file here: https://drive.google.com/file/d/0B_z0joRLczLdTEcwbzMxTTQxRFU/view?usp=sharing

Sheet one is the raw data. Sheet two is how I need the data to look once complete, with yellow cells indicating the data copied from the highlighted green cells, with each green cell being in a row below the copied yellow cells.

In plain English, I need a Macro that will start in cell B2. If B2 is not blank, then find the first non-blank cell in column J, below row 2, and copy that value into cell J2. I then need it to find the next non-blank cell in column B (in the sample file, cell B9) and perform the same function until it reaches a blank value in Column A (an index column I inserted to unify the data into a single range. I have to do this for multiple columns, but the reference column will always be "B". I'd be happy with a macro that did one column at a time and I could adjust and run as needed, or if I could enter a range of columns, that would be great too. I tried to illustrate in this link: https://drive.google.com/file/d/0B_z0joRLczLdcnRuQlk3RDdTd3M/view?usp=sharing

Please help!

 

[JLGWhiz]

I think I got the gist of what you want to do, but don't follow you on the multiple columns statement. You did not indicate that you wanted to clear the copied cell, so it will be left intact. See if this cures the first problem.

Sub copystuff()
Dim sh As Worksheet, lr As Long
Set sh = Sheets(1) 'Edit sheet name
lr = sh.Cells(Rows.Count, 1).End(xlUp).Row
    With sh
        For Each c In .Range("B2:B" & lr)
            If c <> "" Then
                If c.Offset(1, 8) = "" Then
                    c.Offset(0, 8).End(xlDown).Copy c.Offset(0, 8)
                Else
                    c.Offset(0, 8) = c.Offset(1, 8)
                End If
            End If
        Next
    
    End With
End Sub

 

[curtishavak]

I think this did the trick, thank you! I need to test it against the full worksheet, but it appears to work properly.

Regarding the multiple columns comment, what I meant was that I needed this same functionality for columns J-Q [c.Offset(0,8-15)], for example.

 

[curtishavak]

OK, so this code did work (thank you again), but not perfectly. There is a flaw in the logic in that there is not always going to be data in the column that I'm looking at. For example, in the sample workbook from my initial post, look at column L (Site Address 2). When I run the macro, the code tells it to go to the next blank cell, which applies to the second Party, not the first one, so it copies the information for Site Address 2 from Party 2 to Party 1, which is incorrect.

I think a good solution would be to use a reference column that will always have a value in the row that we need to copy, even if the column that we're trying to copy from doesn't have data in that row. This reference column would be column I (Site Location ID). This column always has data for the row in question. The code would have go there first, then offset to the column in question and copy the data there (even if blank). I tried to modify the code as follows and it appears to be working in the sample worksheet. Can you take a look and let me know if you think my logic works (I've modified the code to look at Column L (Site Address 2, Offset 10 instead of 8)?

Sub copystuff()
Dim sh As Worksheet, lr As Long
Set sh = Sheets(1) 'Edit sheet name
lr = sh.Cells(Rows.Count, 1).End(xlUp).Row
    With sh
        For Each c In .Range("B2:B" & lr)
            If c <> "" Then
                If c.Offset(1, 10) = "" Then
                    c.Offset(0, 7).End(xlDown).Select
                    ActiveCell.Offset(0,3).Copy c.Offset(0, 10)
                Else
                    c.Offset(0, 10) = c.Offset(1, 10)
                End If
            End If
        Next
    
    End With
End Sub[FONT=century gothic]

[/FONT]

 

[JLGWhiz]

OK, so this code did work (thank you again), but not perfectly. There is a flaw in the logic in that there is not always going to be data in the column that I'm looking at. For example, in the sample workbook from my initial post, look at column L (Site Address 2). When I run the macro, the code tells it to go to the next blank cell, which applies to the second Party, not the first one, so it copies the information for Site Address 2 from Party 2 to Party 1, which is incorrect.

I think a good solution would be to use a reference column that will always have a value in the row that we need to copy, even if the column that we're trying to copy from doesn't have data in that row. This reference column would be column I (Site Location ID). This column always has data for the row in question. The code would have go there first, then offset to the column in question and copy the data there (even if blank). I tried to modify the code as follows and it appears to be working in the sample worksheet. Can you take a look and let me know if you think my logic works (I've modified the code to look at Column L (Site Address 2, Offset 10 instead of 8)?

Sub copystuff()
Dim sh As Worksheet, lr As Long
Set sh = Sheets(1) 'Edit sheet name
lr = sh.Cells(Rows.Count, 1).End(xlUp).Row
    With sh
        For Each c In .Range("B2:B" & lr)
            If c <> "" Then
                If c.Offset(1, 10) = "" Then
                    c.Offset(0, 7).End(xlDown).Select
                    ActiveCell.Offset(0,3).Copy c.Offset(0, 10)
                Else
                    c.Offset(0, 10) = c.Offset(1, 10)
                End If
            End If
        Next
    
    End With
End Sub[FONT=century gothic]

[/FONT]

If you are happy with it, I am happy with it.
Regards, JLG

 

[curtishavak]

Thanks again!