Copy paste data

[Abhijeet]

Hi

I want copy paste data in other worksheet according the Header in that sheet 2

From this file I want Sheet 2 header according copy data from sheet 1 paste into sheet 2 with help of macro

 

[Smallman]

Hi Abhijeet

Thanks for uploading a workbook. I had a little trouble with the rhetoric above but the file seemed pretty clear. What ever headers you put in Sheet 2, you would like that data extracted and put in Sheet1. If this is the case then the following should work for you.

Option Explicit
Sub Testo()
Dim i As Integer
Dim j As Integer
Dim ar As Variant
 
Sheet2.[A2:Z2000].ClearContents
ar = Sheet2.Range("A1", Sheet2.Range("IV1").End(xlToLeft))
 
    For i = 1 To Sheet2.Range("IV1").End(xlToLeft).Column
        j = [a1:Z1].Find(ar(1, i)).Column
        Range(Cells(2, j), Cells(Rows.Count, j).End(xlUp)).Copy Sheet2.Cells(2, i)
    Next i
End Sub

File attached to show workings.

Take care

Smallman

 

[Abhijeet]

Its work can give me whole excel range i think this range a1:z2000

 

[Smallman]

Sure, this should keep you going.

Sheet2.[a10].CurrentRegion.ClearContents

Take care

Smallman

 

[Smallman]

Mmm

You are going to want to keep those headers aren't you?

Sheet2.[A1].CurrentRegion.Offset(1).ClearContents

This should work in that case.

Take care

Smallman

 

[Abhijeet]

Please upload file with whole sheet range

 

[Smallman]

Just cut that line out and replace it with the line you originally requested enhancement for. It is not that difficult.

Smallman

 

[Abhijeet]

Option Explicit
Sub Testo()
Dim i As Integer
Dim j As Integer
Dim ar As Variant

Sheet2.[A1].CurrentRegion.Offset(1).ClearContents
ar = Sheet2.Range("A1", Sheet2.Range("IV1").End(xlToLeft))

For i = 1 To Sheet2.Range("IV1").End(xlToLeft).Column
j = [a1:Z1].Find(ar(1, i)).Column
Range(Cells(2, j), Cells(Rows.Count, j).End(xlUp)).Copy Sheet2.Cells(2, i)
Next i
End Sub

 

[Abhijeet]

Is this code is correct

 

[Smallman]

Looks good to me. Let me just test it and I will edit this post shortly.

Take care

Smallman

EDIT - Yep went like the clappers for me!!! I have written this code so you can completely destroy the list in Sheet2 and come up with a new list no matter the length and it will adapt the results to the size of the list. I have limited the search range from A to Z but you could extend this if need be. It won't slow the code down any, I just saw that you had quite a modest list so limited it in this way. Happy XLing!!!

 

[Abhijeet]

It is not work please upload whole range file

 

[Smallman]

What code are you running? This code runs like a dream every time. There is of course no error trapping for Typos at the Op end. Assumes you actually have some data in the original Sheet2 to start with but you have to make some assumptions.

Smallman

 

[Abhijeet]

This macro not work if range is expand in last row & column error is show in j = [a1:Z1].Find(ar(1, i)).Column this line

 

[Smallman]

Taking the information right out of the procedure I gave you the answer to your question is as follows.

j = Range("A1", Range("IV1").End(xlToLeft)).Find(ar(1, i)).Column

This is line 2 from the file attached. Look at what you have to see if you can see parts you can re use. When you are learning this is the essence of programming. I probably should have fixed this in the first place but your data set was so small I thought I had given you a range far and a way large enough.

Take care

Smallman

 

[Abhijeet]

No its not work can u check from side & please upload file with data in last row & column

 

[Smallman]

Seems to work fine in the file attached.

I am going out to meet my wife. Will be back at the computer in a couple of hours. Will check in then.

Take care

Smallman

 

[Abhijeet]

Sorry my dear i mean to say in sheet1 data in IV1:65000 then it is not work

 

[Smallman]

Ha ha

That made me laugh. Language is a wonderful thing. Can you upload a file which is not working cause it is all hunky dory at my end.

Ta

Smallman

 

[shrivallabha]

It is coincidence that you are referring to the 256th column. Try changing

j = Range("A1", Range("IV1").End(xlToLeft)).Find(ar(1, i)).Column

to

j = Range("A1", Cells(1,Columns.Count).End(xlToLeft)).Find(ar(1, i)).Column

and see if it works....

 

[Abhijeet]

No its not work error in j = Range("A1", Cells(1,Columns.Count).End(xlToLeft)).Find(ar(1, i)).Column (cells) so please upload the file

 

[Smallman]

Hi Abhijeet

As stated before can you upload your workbook. Happy to debug it for you.

Take care

Smallman

 

[Abhijeet]

Please see this file

 

[shrivallabha]

See if below works for you.

Option Explicit
Sub Testo()
Dim i As Integer, lastRow As Long
Dim ar As Range, PstRng As Range

lastRow = Range("A" & Rows.Count).End(xlUp).Row
Sheet2.[A1].CurrentRegion.Offset(1).ClearContents
Set ar = Sheet2.Range("A1", Sheet2.Cells(1, Columns.Count).End(xlToLeft))

For i = 1 To Cells(1, Columns.Count).End(xlToLeft).Column
    Set PstRng = ar.Find(Cells(1, i).Value, [A1], xlValues, xlWhole)
    If Not PstRng Is Nothing Then
        Range(Cells(2, i), Cells(lastRow, i)).Copy PstRng.Offset(1, 0)
    End If
Next i

End Sub

 

[Smallman]

That is an XLS spreadsheet which means it is an XL 03 file. Which means the last file that I posted should work fine. Here is that file and that file goes well.

Here is the code - gold.

Option Explicit
Sub Testo()
Dim i As Integer
Dim j As Integer
Dim ar As Variant
 
Sheet2.[A1].CurrentRegion.Offset(1).ClearContents
ar = Sheet2.Range("A1", Sheet2.Range("IV1").End(xlToLeft))
 
For i = 1 To Sheet2.Range("IV1").End(xlToLeft).Column
    j = Range("A1", Range("IV1").End(xlToLeft)).Find(ar(1, i)).Column
    Range(Cells(2, j), Cells(Rows.Count, j).End(xlUp)).Copy Sheet2.Cells(2, i)
Next i
End Sub

Take care

Smallman

 

[Abhijeet]

Option Explicit
Sub Testo()
Dim i As Integer, lastRow As Long
Dim ar As Range, PstRng As Range

lastRow = Range("A" & Rows.Count).End(xlUp).Row
Sheet2.[A1].CurrentRegion.Offset(1).ClearContents
Set ar = Sheet2.Range("A1", Sheet2.Cells(1, Columns.Count).End(xlToLeft))

For i = 1 To Cells(1, Columns.Count).End(xlToLeft).Column
Set PstRng = ar.Find(Cells(1, i).Value, [A1], xlValues, xlWhole)
If Not PstRng Is Nothing Then
Range(Cells(2, i), Cells(lastRow, i)).Copy PstRng.Offset(1, 0)
End If
Next i

End Sub



this code not work in 2003 excel file