Question : VBA excel or access data collapse

My data is available in either excel or access, so whichever makes the solution easier.

My problem is I am going to remove duplicate company names but not all records have phone, fax and email.

For example.

company phone fax email

abc 123
abc 456
abc [email protected]
abc 123

def 456
def
def
def [email protected]

ghi
ghi 123
ghi

If I delete duplicates, I dont want to loose data that might be available from another record for the same company.

From what you can see not all records have phone #, fax & email,,, if they have them atall.

After running the vba, I'd like the data above to look like this

company phone fax email

abc 123 456 [email protected]
abc 123 456 [email protected]
abc 123 456 [email protected]
abc 123 456 [email protected]

def 456 [email protected]
def 456 [email protected]
def 456 [email protected]
def 456 [email protected]

ghi 123
ghi 123
ghi 123

So I can delete the duplicates without trouble.

Answer : VBA excel or access data collapse

run the sub in the attached workbook

                       
         
           
             1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:

           
           
             Sub runme()

Dim s As Worksheet
Set s = Sheet1

irow = 2

Dim phoneS As String, faxS As String, emailS As String

Do While LenB(s.Cells(irow, "A").Value) > 0

    irow2 = irow
    phoneS = vbNullString
    faxS = vbNullString
    emailS = vbNullString
    
    Do While LenB(s.Cells(irow, "A").Value) > 0
        If LenB(s.Cells(irow, "B").Value) > 0 Then
            phoneS = s.Cells(irow, "B").Value
        End If
        If LenB(s.Cells(irow, "C").Value) > 0 Then
            faxS = s.Cells(irow, "C").Value
        End If
        If LenB(s.Cells(irow, "D").Value) > 0 Then
            emailS = s.Cells(irow, "D").Value
        End If
        irow = irow + 1
    Loop
    irow = irow2
    Do While LenB(s.Cells(irow, "A").Value) > 0
        s.Cells(irow, "B").Value = phoneS
        s.Cells(irow, "C").Value = faxS
        s.Cells(irow, "D").Value = emailS
        irow = irow + 1
    Loop
    
    Do While LenB(Trim$(s.Cells(irow, "A").Value)) = 0 And irow < s.UsedRange.Rows.Count
        irow = irow + 1
    Loop

Loop

End Sub

           
         

example.xls (26 KB) (File Type Details)

example