Hi Guys,
I have some code that copies some columns of data based on the text typed into an input box. Code below is working great.
What I would like to achieve if possible is 2 more input boxes asking for the destination workbook name and also the sheet name within the destination workbook.
The code will then open the destination workbook and relevant sheet then copy the columns of data from master workbook and paste them into the chosen destination workbook sheets, appending any data already existing.
The workbook and the necessary sheet names will all ready exist.
Thanks
[/CODE]Option Explicit Option Compare Text '< ignore case '
Sub Searchcolumns()
'
Dim FirstAddress As String, WhatFor As String
Dim Cell As Range, Sheet As Worksheet
Dim wkb As Workbook
Do
WhatFor = InputBox("What are you looking for?", "Search Criteria")
If StrPtr(WhatFor) = 0 Then Exit Sub
Loop Until Len(WhatFor) > 0
Application.ScreenUpdating = False
'Will add new workbook
Set wkb = Workbooks.Add(1)
'
For Each Sheet In ThisWorkbook.Worksheets
'If Sheet.Name <> "SEARCH" Then 'this can be deleted when copying to a new workbook
With Sheet.Rows(2)
Set Cell = .Find(WhatFor, LookIn:=xlValues, LookAt:=xlPart)
If Not Cell Is Nothing Then
FirstAddress = Cell.Address
Do
Sheet.Range("A1").EntireColumn.Copy _
Destination:=wkb.Sheets(1).Cells(1, wkb.Sheets(1).Columns.Count).End(xlToLeft).Offset(0, 1)
Sheet.Range("B1").EntireColumn.Copy _
Destination:=wkb.Sheets(1).Cells(1, wkb.Sheets(1).Columns.Count).End(xlToLeft).Offset(0, 1)
Cell.EntireColumn.Copy _
Destination:=wkb.Sheets(1).Cells(1, wkb.Sheets(1).Columns.Count).End(xlToLeft).Offset(0, 1)
Set Cell = .FindNext(Cell)
Loop Until Cell.Address = FirstAddress
End If
End With
'End If 'this can be deleted when copying to a new workbook
Set Cell = Nothing
Next Sheet
'
'AutoFit All Columns on Worksheet
wkb.Worksheets(1).Cells.EntireColumn.AutoFit
Application.ScreenUpdating = True
End Sub
[/CODE]
I have some code that copies some columns of data based on the text typed into an input box. Code below is working great.
What I would like to achieve if possible is 2 more input boxes asking for the destination workbook name and also the sheet name within the destination workbook.
The code will then open the destination workbook and relevant sheet then copy the columns of data from master workbook and paste them into the chosen destination workbook sheets, appending any data already existing.
The workbook and the necessary sheet names will all ready exist.
Thanks
[/CODE]Option Explicit Option Compare Text '< ignore case '
Sub Searchcolumns()
'
Dim FirstAddress As String, WhatFor As String
Dim Cell As Range, Sheet As Worksheet
Dim wkb As Workbook
Do
WhatFor = InputBox("What are you looking for?", "Search Criteria")
If StrPtr(WhatFor) = 0 Then Exit Sub
Loop Until Len(WhatFor) > 0
Application.ScreenUpdating = False
'Will add new workbook
Set wkb = Workbooks.Add(1)
'
For Each Sheet In ThisWorkbook.Worksheets
'If Sheet.Name <> "SEARCH" Then 'this can be deleted when copying to a new workbook
With Sheet.Rows(2)
Set Cell = .Find(WhatFor, LookIn:=xlValues, LookAt:=xlPart)
If Not Cell Is Nothing Then
FirstAddress = Cell.Address
Do
Sheet.Range("A1").EntireColumn.Copy _
Destination:=wkb.Sheets(1).Cells(1, wkb.Sheets(1).Columns.Count).End(xlToLeft).Offset(0, 1)
Sheet.Range("B1").EntireColumn.Copy _
Destination:=wkb.Sheets(1).Cells(1, wkb.Sheets(1).Columns.Count).End(xlToLeft).Offset(0, 1)
Cell.EntireColumn.Copy _
Destination:=wkb.Sheets(1).Cells(1, wkb.Sheets(1).Columns.Count).End(xlToLeft).Offset(0, 1)
Set Cell = .FindNext(Cell)
Loop Until Cell.Address = FirstAddress
End If
End With
'End If 'this can be deleted when copying to a new workbook
Set Cell = Nothing
Next Sheet
'
'AutoFit All Columns on Worksheet
wkb.Worksheets(1).Cells.EntireColumn.AutoFit
Application.ScreenUpdating = True
End Sub
[/CODE]