Excel VB Macro Solved/Closed

Question

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

venkat1926 · Answer

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

b_85 · Answer

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.

venkat1926 · Answer

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

b_85 · Answer

Thanks so much, it works perfectly now

Excel VB Macro

4 responses

Similar discussions

Subscribe To Our Newsletter!