Hi All,
New to the form, I have a little tricky VBA I'm trying to create. What I currently have is two other macros which search two sheets for vendor names and creates new sheets with their specific information. This leaves me with approx 40 sheets, now what I'm trying to do is write a macro that will search for the vendor name in the sheet tile and save all the sheets associated with that vendor to a new workbook (if one exists update the current sheets in that workbook). I will have a list of vendors in one sheet that I would like to use as the search criteria. Here is an example of the first macro I run
Option Explicit
Looking around and trying to copy that has left me with this VBA which doesn't work (just for testing I'm hard coding the look up name)
New to the form, I have a little tricky VBA I'm trying to create. What I currently have is two other macros which search two sheets for vendor names and creates new sheets with their specific information. This leaves me with approx 40 sheets, now what I'm trying to do is write a macro that will search for the vendor name in the sheet tile and save all the sheets associated with that vendor to a new workbook (if one exists update the current sheets in that workbook). I will have a list of vendors in one sheet that I would like to use as the search criteria. Here is an example of the first macro I run
Option Explicit
Code:
' Developed by Contextures Inc.
' www.contextures.com
Sub ERP_POS()
Dim ws1 As Worksheet
Dim wsNew As Worksheet
Dim rng As Range
Dim r As Integer
Dim c As Range
Dim bAF As Boolean
Set ws1 = Sheets("ERP_POS")
Set rng = Range("Database")
bAF = ws1.AutoFilterMode
'extract a list of Sales Reps
With ws1
.Columns("P:P").Copy _
Destination:=.Range("X1")
.Columns("X:X").AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=.Range("Y1"), Unique:=True
r = .Cells(Rows.Count, "Y").End(xlUp).Row
.Columns("X:X").ClearContents
'set up Criteria Area
.Range("X1").Value = .Range("P1").Value
For Each c In .Range("Y2:Y" & r)
'add the rep name to the criteria area
.Range("X2").Value = _
"=""="" & " & Chr(34) & c.Value & Chr(34)
'add new sheet (if required)
'and run advanced filter
If WksExists("ERP_POS" & " " & c.Value) Then
Sheets("ERP_POS" & " " & c.Value).Cells.Clear
rng.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=.Range("X1:X2"), _
CopyToRange:=Sheets("ERP_POS" & " " & c.Value).Range("A1"), _
Unique:=False
Else
Set wsNew = Sheets.Add
wsNew.Move After:=Worksheets(Worksheets.Count)
wsNew.Name = "ERP_POS" & " " & c.Value
rng.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=.Range("X1:X2"), _
CopyToRange:=wsNew.Range("A1"), _
Unique:=False
End If
Next
.Select
.Columns("Y:X").EntireColumn.Delete
If bAF = True Then
.Range("A1").AutoFilter
End If
End With
End Sub
Function WksExists(wksName As String) As Boolean
On Error Resume Next
WksExists = CBool(Len(Worksheets(wksName).Name) > 0)
End Function
Looking around and trying to copy that has left me with this VBA which doesn't work (just for testing I'm hard coding the look up name)
Code:
Sub Test1234()
'
' Test1234 Macro
'
Dim ws As Worksheet
Dim ws2 As Worksheet
ws = Worksheet.Name
Dim c As Range
c = "VendorA"
For Each ws In ActiveWorkbook.Worksheets
If ws.Name Like "*c.Value*" Then
Set ws2 = Worksheet.Name
Sheets(ws2).Select
Sheets(ws2).Copy
ActiveWorkbook.SaveAs Filename:="C:\Users\brobbin\Desktop\c.Value.xlsx", _
FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
End If
Next ws
End Sub