Loop for Transpose

[DetroitDavid]

I’m wondering if someone could help me write a loop.

I am a foreclosure defense specialist. I help people who’s home is in the foreclosure process. Very rewarding, but also very tedious. I need to call thousands of people who show up on public record after the bank sends an address to foreclosure. I have an auto dialer but I am struggling with getting the information into excel in the right format to use the dialer.

I have a spreadsheet, 3,000 +/- rows and 49 columns. The last 36 of the columns are 12 sets each of FirstName, LastName, Phone (see screenshot below - if it worked – Note all information is bogus).

Each row is a unique postal address, but each address I import can have up to 12 contact numbers. Some have none, some 1, and so forth.

I need to do something like using the Paste Special Transform feature.

For each row, I want to have the information in the first 7 columns repeated down so it now is duplicated into X rows; then for each FirstName, LastName, Phone “set” put one set onto each of the X rows with duplicate info on the first 7 cols. So I end up with (in this case) X records that have the same address, but potentially X different names and phone numbers. I only need the new split record written back if it has a unique phone number for that address.

So, within a loop, for each row (unique address) I’d like it to count the phone numbers from the 12 sets of 3. Then if a phone number exists, insert that many rows, duplicate the information from the first few cells x times, then put the FirstName, LastName and corresponding Phone number on each of the x records.

The average number of phone numbers listed for an address is about 4, so theoretically, if I start with a 3,000 record spreadsheet, it might end up being 12,000 rows when completed.

I don’t know where to start, and would really appreciate someone seeing this as a simple challenge and helping me out.

Thank you so much in advance…

David

Excel 2010
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R	S	T	U	V	W	X	Y	Z	AA	AB	AC	AD	AE	AF	AG	AH	AI	AJ	AK	AL	AM	AN	AO	AP	AQ	AR	AS	AT	AU	AV	AW	AX
1		Action	Address	City	State	Zip	Import	Auction	Call	Time	Notes	First_Contact	Last_Contact	Phone_Contact	First_Name_1	Last_Name_1	Phone_1	First_Name_2	Last_Name_2	Phone_2	First_Name_3	Last_Name_3	Phone_3	First_Name_4	Last_Name_4	Phone_4	First_Name_5	Last_Name_5	Phone_5	First_Name_6	Last_Name_6	Phone_6	7	Last_Name_7	Phone_7	First_Name_8	Last_Name_8	Phone_8	First_Name_9	Last_Name_9	Phone_9	First_Name_10	Last_Name_10	Phone_10	First_Name_11	Last_Name_11	Phone_11	First_Name_12	Last_Name_12	Phone_12
2	1		21810 Eastland Ct	Highland Park	MI	480891745	Feb 4	Feb 12									(586) 731-1234	Cynthia	Bury	(586) 558-1234	Cindy	Bury	(586) 558-1234	Cindy	Bury	(586) 677-1234	Cindy	Bury	(586) 855-4364			(586) 558-1234
3	2		25394 Waldorf St	Detroit	MI	480475730	Feb 4	Feb 12							Deb	Miley	(586) 726-1234	Howard	Miley		Deborah	Miley		Howard	Miley	(586) 294-1234	Howard	Miley	(586) 945-6072	Miley	Howard
4	3		6385 68th St SE	Warren	MI	480443814	Feb 4	Feb 12							Wanda	Latondras	(586) 709-1234	Wanda	Latondras	(586) 677-1234	Wanda	Latondras	(586) 677-1234			(586) 709-1234						(586) 677-1234
5	4		6526 Tanglewood Dr SE	Chesterfield	MI	485052710	Feb 4	Feb 12							Andrew	URBAN		Ann	URBAN	(586) 294-1234			(586) 294-1234									(586) 294-1234
6	5		830 Adams St SE	Bruce Twp	MI	484639727	Feb 4	Feb 12							Roy	KIRCHOFF	(586) 945-1234	Roy	Kirchoff		Roy	Kirchoff	(586) 477-1234	Roy	Kirchoff	(586) 945-1234	Roy	Kirchoff	(586) 558-8659	Roy	Kirchoff
7	6		4087 Silver Lake Rd	Sterling Heights	MI	484339724	Feb 4	Feb 12							Kathleen	Stitchick										(586) 731-1234						(586) 477-1234
8	7		2017 Morgan Rd	Harrison Township	MI	484581437	Feb 4	Feb 12							Robert	Decker	(586) 383-1234	Robert	Decker		Robert	Decker	(586) 777-1234			(586) 726-1234						(586) 777-1234
Mar Calls

 

[NeonRedSharpie]

Sub makeList()

    Dim raw As Worksheet
    Dim list As Worksheet
    
    Dim nextRow As Integer
    
    nextRow = 2
    
    Set raw = Sheets("Mar Calls")
    Set list = Sheets("List") 'Change me to your destination sheet name
    
    With raw
        For x = 2 To .Cells(Rows.Count, 2).End(xlUp).Row
            For y = 16 To 49 Step 3
                list.Range(list.Cells(nextRow, 1), list.Cells(nextRow, 10)).Value = _
                    .Range(.Cells(x, 1), .Cells(x, 10)).Value
                    
                If .Cells(x, y) <> "" Then
                    list.Range(list.Cells(nextRow, 11), list.Cells(nextRow, 13)).Value = _
                        .Range(.Cells(x, y - 2), .Cells(x, y)).Value
                    nextRow = nextRow + 1
                End If
            Next y
        Next x
        
    End With
End Sub

This will place them on a new sheet, ensuring data integrity.

 

[DetroitDavid]

Thank you - worked like a charm!