PDA

View Full Version : Need Help: reorganizing exported info



teachingkids
11-04-2008, 10:24 AM
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!

xld
11-04-2008, 10:33 AM
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

teachingkids
11-04-2008, 10:46 AM
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?

xld
11-04-2008, 11:09 AM
This deletes themm if column A and column D match



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

teachingkids
11-04-2008, 01:38 PM
That didn't work out.

xld
11-04-2008, 02:09 PM
Care to share with us?

teachingkids
11-04-2008, 02:12 PM
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.