Need Macro for create address book

[jack999]

I have excel workbook contains Name and address as on the format of sample workbook sheet2. I want to copy it in the format of sheet1 of sample workbook. Sheet1 data contains in alphabetical order.Data of Sheet2 starts from B2. I need a macro for copy this data from sheet2 to Sheet1 as the format uploaded.

Thanks

 

[Debraj]

Hi Jack,

check if its works for you..

Sub SpliMultiple()
Dim frw As Long, lrw As Long, fcol As Long, lcol As Long, deb As Range
Set deb = Sheets(2).Range("B1").CurrentRegion
frw = deb.Cells(1).Row + 1
lrw = 1
fcol = deb.Cells(1, 1).Column
lcol = deb.Columns.Count + fcol - 1
 
Sheets(1).Select
For i = 1 To deb.Rows.Count
    Range(Cells(lrw, frw), Cells(lrw + deb.Columns.Count - 1, frw)) = WorksheetFunction.Transpose(deb.Rows(i))
    lrw = Cells(lrw, fcol).Row + deb.Columns.Count + 1
Next i
End Sub

 

[shrivallabha]

With your data being systematic, you use a formula as well.
In Sheet2, Cell B2 insert following formula

=INDEX(Sheet1!$B$1:$B$100,(ROWS($A$1:A1)-1)*6+COLUMNS($A$1:A1))

and then copy down and across until you get errors. Make sure you adjust $B$100 part to actual last row of your data.

 

[jack999]

Hi Jack,

check if its works for you..

Sub SpliMultiple()
Dim frw As Long, lrw As Long, fcol As Long, lcol As Long, deb As Range
Set deb = Sheets(2).Range("B1").CurrentRegion
frw = deb.Cells(1).Row + 1
lrw = 1
fcol = deb.Cells(1, 1).Column
lcol = deb.Columns.Count + fcol - 1
 
Sheets(1).Select
For i = 1 To deb.Rows.Count
    Range(Cells(lrw, frw), Cells(lrw + deb.Columns.Count - 1, frw)) = WorksheetFunction.Transpose(deb.Rows(i))
    lrw = Cells(lrw, fcol).Row + deb.Columns.Count + 1
Next i
End Sub

Thanks A Lot

 

[jack999]

With your data being systematic, you use a formula as well.
In Sheet2, Cell B2 insert following formula

=INDEX(Sheet1!$B$1:$B$100,(ROWS($A$1:A1)-1)*6+COLUMNS($A$1:A1))

and then copy down and across until you get errors. Make sure you adjust $B$100 part to actual last row of your data.

Thanks A Lot

 

[jack999]

With your data being systematic, you use a formula as well.
In Sheet2, Cell B2 insert following formula

=INDEX(Sheet1!$B$1:$B$100,(ROWS($A$1:A1)-1)*6+COLUMNS($A$1:A1))

and then copy down and across until you get errors. Make sure you adjust $B$100 part to actual last row of your data.

Sir, I want to copy from sheet2 to Sheet1; Copy paste special transpose wise.

 

[shrivallabha]

Yes. That is pretty much doable using formula I have posted. I am attaching modified file for your reference.

 

[jack999]

Hi Jack,

check if its works for you..

Sub SpliMultiple()
Dim frw As Long, lrw As Long, fcol As Long, lcol As Long, deb As Range
Set deb = Sheets(2).Range("B1").CurrentRegion
frw = deb.Cells(1).Row + 1
lrw = 1
fcol = deb.Cells(1, 1).Column
lcol = deb.Columns.Count + fcol - 1
 
Sheets(1).Select
For i = 1 To deb.Rows.Count
    Range(Cells(lrw, frw), Cells(lrw + deb.Columns.Count - 1, frw)) = WorksheetFunction.Transpose(deb.Rows(i))
    lrw = Cells(lrw, fcol).Row + deb.Columns.Count + 1
Next i
End Sub

Sir

Some error showing as follows
When I run the macro its copy Sheet2 Heading also to the sheet1. Sheet2 Column A contains formula.
Actually range is Sheet2 B2:F200

When I remove sheet2 Column A and Heading its copying properly.
Can you modify this code as suitable for me
Thanks and Regards

 

[jack999]

Yes. That is pretty much doable using formula I have posted. I am attaching modified file for your reference.

Thank you so much sir.

 

[jack999]

Hi Jack,

check if its works for you..

Sub SpliMultiple()
Dim frw As Long, lrw As Long, fcol As Long, lcol As Long, deb As Range
Set deb = Sheets(2).Range("B1").CurrentRegion
frw = deb.Cells(1).Row + 1
lrw = 1
fcol = deb.Cells(1, 1).Column
lcol = deb.Columns.Count + fcol - 1
 
Sheets(1).Select
For i = 1 To deb.Rows.Count
    Range(Cells(lrw, frw), Cells(lrw + deb.Columns.Count - 1, frw)) = WorksheetFunction.Transpose(deb.Rows(i))
    lrw = Cells(lrw, fcol).Row + deb.Columns.Count + 1
Next i
End Sub

Sir, Can you modify the cod as I replied before.

 

[Debraj]

oops.. I missed the post..

try the same..
just change this line..

For i = 2 To deb.Rows.Count

complete code pasted again..

Sub SpliMultiple()
Dim frw As Long, lrw As Long, fcol As Long, lcol As Long, deb As Range
Set deb = Sheets(2).Range("B1").CurrentRegion
frw = deb.Cells(1).Row + 1
lrw = 1
fcol = deb.Cells(1, 1).Column
lcol = deb.Columns.Count + fcol - 1
 
Sheets(1).Select
For i = 2 To deb.Rows.Count
    Range(Cells(lrw, frw), Cells(lrw + deb.Columns.Count - 1, frw)) = WorksheetFunction.Transpose(deb.Rows(i))
    lrw = Cells(lrw, fcol).Row + deb.Columns.Count + 1
Next i
End Sub

lemme know if you need the heading also in sheet1 > column A..