Copy columns using VBA

[Dee]

Dear All,


i am trying to copy columns form sheet called "Productivity_Project_Record" to "Project List" only those columns whose heading are there in sheet "Headers" ie., from A1 to A55.


Here is my code i am struggling with...

can any one of you pls help me on this


Private Sub copyWithSelectedHeaders()


Dim row As Long

Dim column As Long

Dim copiedRow As Long

Dim fromSht As Worksheet

Dim toSht As Worksheet

Dim headerSht As Worksheet


fromSht = Sheets("Productivity_Project_Record")

toSht = Sheets("Project List")

headerSht = Sheets("Headers")


copiedRow = 2

Dim rgFoundCell As Range

'Assumption is that the rowheaders are available in the first row, which is skipped.

For row = 2 To fromSht.UsedRange.Rows.Count

For column = 1 To fromSht.UsedRange.Columns.Count

If fromSht.Cells(row, column) <> "" Then


rgFoundCell = Worksheets("Headers").Range("headings").Find(what:=fromSht.Cells(1, column))


If (rgFoundCell Is Nothing) Then

'column header not found

Else

rgFoundCell = toSht.Range("A1:BZ1").Find(what:=fromSht.Cells(1, column))

If rgFoundCell Is Nothing Then

'some thing wrongas thereisno matchingheader in tosheet.

Else

toSht(copiedRow, rgFoundCell.column).Cells = fromSht.Cells(row, column)

copiedRow = copiedRow + 1

End If

End If


End If


Next column

Next row


End Sub


Thanking you in advance,

Dee

 

[dan_l]

So you only want to copy rows where where the value in column A matches a value on a list?

 

[Dee]

HI,

I have list of heading in Sheet "Headers", if these headers list matches with column headings of "Productivity_Project_Record" then it should copy the entire column from "Productivity_Project_Record" to corresponding columns in "Project List".

Hope i am clear


Thank you,

Dee

 

[Dee]

Hi guys,

I wrote the below stuff to do the same but the problem here is it copying all the data to first column of the "Project list" sheet instead of corresponding columns.


Can any one of help me on this pls ?


Private Sub copyWithSelectedHeaders()


Dim row As Long

Dim column As Long

Dim copiedRow As Long

Dim fromSht As Worksheet

Dim toSht As Worksheet

Dim headerSht As Worksheet


Application.ScreenUpdating = False


Set fromSht = Sheets("Productivity_Project_Record")

Set toSht = Sheets("Project List")

Set headerSht = Sheets("Headers")


copiedRow = 2

Dim rgFoundCell As Range

Dim rowModified As Boolean

rowModified = False


'Assumption is that the rowheaders are available in the first row, which is skipped.

For row = 2 To fromSht.UsedRange.Rows.Count

rowModified = False

For column = 1 To fromSht.UsedRange.Columns.Count

' If fromSht.Cells(row, column) <> "" Then


Set rgFoundCell = Worksheets("Headers").Range("headings").Find(what:=fromSht.Cells(1, column))


If (rgFoundCell Is Nothing) Then

'column header not found

Else

rgFoundCell = toSht.Range("A1:BZ1").Find(what:=fromSht.Cells(1, column))

If rgFoundCell Is Nothing Then

'some thing wrongas thereisno matchingheader in tosheet.

Else

toSht.Cells(copiedRow, rgFoundCell.column) = fromSht.Cells(row, column)

rowModified = True

End If

End If


' End If


Set rgFoundCell = Nothing

Next column

If (rowModified = True) Then

copiedRow = copiedRow + 1

End If

Set rgFoundCell = Nothing

Next row

Application.ScreenUpdating = True


End Sub


Private Sub Workbook_Open()

copyWithSelectedHeaders

End Sub


Thanking you in advance,

Dee

 

[Hui]

[pre]

Sub APcolumns()

Dim col As Long
Dim rng As Range
Dim temp As Range

Set rng = Sheets("Project List").Range("A1:BZ1")
For Each c In rng
Sheets("Headers").Activate

Set temp = Sheets("Headers").Range("headings").Find(c.Value, LookIn:=xlValues)
If Not temp Is Nothing Then

Worksheets("Productivity_Project_Record").Activate
col = Sheets("Productivity_Project_Record").Range("1:1").Find(temp.Value, LookIn:=xlValues).Column

Worksheets("Productivity_Project_Record").Columns(col).Copy

Worksheets("Project List").Activate
col = Sheets("Project List").Range("1:1").Find(temp.Value, LookIn:=xlValues).Column

ActiveSheet.Paste Destination:=Worksheets("Project List").Columns(col)

End If

Next

End Sub

[/pre]