Need Help: reorganizing exported info

[teachingkids]

I have a range of information exported from another app that I need to reorganize.

In each row there are between 1 and 4 phone numbers in columns D-G with various contact information in columns A-C. I need the information arranged so that there is only one phone number per row.

So if there are are phone numbers in columns D, E, and G with a blank in F, I need to have 3 rows, each with only one phone number and all the same contact information from columns A-C.

I've taken some VB but this is beyond me. Any help would be greatly appreciated!

[Bob Phillips]

[vba]

Public Sub ProcessData()
Dim i As Long
Dim LastRow As Long
Dim j As Long
With Application

.ScreenUpdating = False
.Calculation = xlCalculationManual
End With

With ActiveSheet

LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
For i = LastRow To 2 Step -1

For j = 7 To 5 Step -1

If .Cells(i, j).Value <> "" Then

.Rows(i + 1).Insert
.Cells(i, "A").Resize(, 3).Copy .Cells(i + 1, "A")
.Cells(i, j).Copy .Cells(i + 1, "D")
End If
Next j
.Cells(i, "E").Resize(, 3).ClearContents
If .Cells(i, "D").Value = "" Then Rows(i).Delete
Next i
End With

With Application

.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With

End Sub
[/vba]

[teachingkids]

Wow! That was a quick reply. Thank you so much!

One more question, can you show me how to delete the rows that contain the same phone numbers?

[Bob Phillips]

This deletes themm if column A and column D match

[vba]

Public Sub ProcessData()
Dim i As Long
Dim LastRow As Long
Dim j As Long
With Application

.ScreenUpdating = False
.Calculation = xlCalculationManual
End With

With ActiveSheet

LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
For i = LastRow To 2 Step -1

For j = 7 To 5 Step -1

If .Cells(i, j).Value <> "" Then

.Rows(i + 1).Insert
.Cells(i, "A").Resize(, 3).Copy .Cells(i + 1, "A")
.Cells(i, j).Copy .Cells(i + 1, "D")
End If
Next j
.Cells(i, "E").Resize(, 3).ClearContents
If .Cells(i, "D").Value = "" Then Rows(i).Delete
Next i

LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
For i = LastRow To 2 Step -1

If .Cells(i, "A").Value = .Cells(i - 1, "A").Value And _
.Cells(i, "D").Value = .Cells(i - 1, "D").Value Then

.Rows(i).Delete
End If
Next i

End With

With Application

.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With

End Sub
[/vba]

[teachingkids]

That didn't work out.

[Bob Phillips]

Care to share with us?

[teachingkids]

Oh I'm sorry. It rearranged the data but did not delete the duplicates. Does that help?

And thanks again for all you're doing for me! This is going to save me so much time throughout the year. I'm exporting the phone numbers from our school database and entering them in our automated calling system. I need to update the numbers once a month and with 6000 numbers....well this would be a waste of time to do one at a time.