Excel VB Macro

Solved/Closed
b_85 Posts 4 Registration date Thursday May 19, 2011 Status Member Last seen May 23, 2011 - May 19, 2011 at 09:32 AM
b_85 Posts 4 Registration date Thursday May 19, 2011 Status Member Last seen May 23, 2011 - May 20, 2011 at 06:48 AM
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

venkat1926 Posts 1864 Registration date Sunday June 14, 2009 Status Contributor Last seen August 7, 2021 810
May 20, 2011 at 06:15 AM
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
venkat1926 Posts 1864 Registration date Sunday June 14, 2009 Status Contributor Last seen August 7, 2021 810
May 19, 2011 at 08:41 PM
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
0
b_85 Posts 4 Registration date Thursday May 19, 2011 Status Member Last seen May 23, 2011
May 20, 2011 at 04:23 AM
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.
0
b_85 Posts 4 Registration date Thursday May 19, 2011 Status Member Last seen May 23, 2011
May 20, 2011 at 06:48 AM
Thanks so much, it works perfectly now
0