Excel VB Macro

Solved/Closed
Report
Posts
4
Registration date
Thursday May 19, 2011
Status
Member
Last seen
May 23, 2011
-
Posts
4
Registration date
Thursday May 19, 2011
Status
Member
Last seen
May 23, 2011
-
Hello,

I am new to vb and excel. I am trying to create a Macro that will look through all the worksheets in a workbook and find the column named "ID". There will be an "ID" column in most of the worksheets. Once the column has been found I would like to copy all the data in that column to a new worksheet.

I manage to locate the ID column using the following coding:

Dim ws As Worksheet
Dim sString As String
Dim sCell As Variant
cfind = "ID"
For Each ws In Worksheets
ws.Activate
On Error Resume Next

If ActiveCell.Value = sfind Then
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
ActiveWindow.ScrollWorkbookTabs Sheets:=2
Sheets("Sheet2").Select
ActiveSheet.Paste


Exit For
End If
Next
End Sub

I am aware that the middle part of the coding does not work which calls to select a range of cells and copy it into a new worksheet.

Many Thanks

4 replies

Posts
1864
Registration date
Sunday June 14, 2009
Status
Contributor
Last seen
August 7, 2021
803
try this modification (if archives sheet is some where in between one column may be blank-delete that blank column )

Sub test() 
Dim ws As Worksheet 
Dim sString As String 
Dim sCell As Variant 
Dim cfind As Range 
Dim j As Integer 
'cfind = "ID" 
For Each ws In Worksheets 
If ws.Name = "archive" Then GoTo nextws 
ws.Activate 
j = ActiveSheet.Index 
'MsgBox j 
On Error Resume Next 
Set cfind = Cells.Find(what:="ID", lookat:=xlWhole) 
If Not cfind Is Nothing Then 
cfind.EntireColumn.Copy 
'Worksheets("archive").Cells(1, Columns.Count).End(xlToLeft).Offset(0, 1).PasteSpecial 
Worksheets("archive").Range("A1").Offset(0, j - 1).PasteSpecial 

''If ActiveCell.Value = sfind Then 
''Range(Selection, Selection.End(xlDown)).Select 
''Selection.Copy 
''ActiveWindow.ScrollWorkbookTabs Sheets:=2 
''Sheets("Sheet2").Select 
''ActiveSheet.Paste 
End If 
nextws: 
Next ws 
End Sub 
1
Thank you

A few words of thanks would be greatly appreciated. Add comment

CCM 2821 users have said thank you to us this month

Posts
1864
Registration date
Sunday June 14, 2009
Status
Contributor
Last seen
August 7, 2021
803
1. do not copy to shee2. but insert a new worksheet and call it "archive".(it can be any name in that case modify the macro)

the columns called ID in the sheets other than "archive" will be copied in the columns in "archive" from left to right.

in archives column A will be blank you can delete that column

modification of your macro is:

Sub test()
Dim ws As Worksheet
Dim sString As String
Dim sCell As Variant
Dim cfind As Range
'cfind = "ID"
For Each ws In Worksheets
If ws.Name = "archive" Then GoTo nextws
ws.Activate
On Error Resume Next
Set cfind = Cells.Find(what:="ID", lookat:=xlWhole)
If Not cfind Is Nothing Then
cfind.EntireColumn.Copy
Worksheets("archive").Cells(1, Columns.Count).End(xlToLeft).Offset(0, 1).PasteSpecial
''If ActiveCell.Value = sfind Then
''Range(Selection, Selection.End(xlDown)).Select
''Selection.Copy
''ActiveWindow.ScrollWorkbookTabs Sheets:=2
''Sheets("Sheet2").Select
''ActiveSheet.Paste
End If
nextws:
Next ws
End Sub
Posts
4
Registration date
Thursday May 19, 2011
Status
Member
Last seen
May 23, 2011

Hi thanks for your help, this works perfectly expect for the fact that the "ID" may not always be in row 1.
I have noticed that if the header is not in row 1 and say in row 2 then it does not copy that column over. Any suggestions?

Thank you very much for your help.
Posts
4
Registration date
Thursday May 19, 2011
Status
Member
Last seen
May 23, 2011

Thanks so much, it works perfectly now