Thanks Bob, yes this is what I would like to do. Tried to insert this code
but error message prompted
'Member or data member not found'
"Bob Phillips" wrote:
> Do you mean
>
> WSNew.Worksheets(2).name = "xxxx"
>
> --
> ---
> HTH
>
> Bob
>
>
> (there's no email, no snail mail, but somewhere should be gmail in my addy)
>
>
>
> "JC" <(E-Mail Removed)> wrote in message
> news:514B7642-A433-4582-B1CE-(E-Mail Removed)...
> > Hi I would like to add the 2nd sheet after Sheet "Rpt_BkgTrend_Market" to
> > capture the value from ws3. Here are the code I have so far. Appreciate if
> > you could help me. Thaks alot
> >
> > Sub Copy_To_Workbooks()
> > Dim CalcMode As Long
> > Dim ws1 As Worksheet
> > Dim ws2 As Worksheet
> > Dim WSNew As Worksheet
> > Dim rng As Range
> > Dim cell As Range
> > Dim Lrow As Long
> > Dim foldername As String
> > Dim MyPath As String
> > Dim FieldNum As Integer
> > Dim FileExtStr As String
> > Dim FileFormatNum As Long
> > Dim NewFn As String
> > NewFn = Format(Sheets("Rpt_BkgTrend").Range("C2"), "yymmdd")
> >
> > Dim ws3 As Worksheet
> > Dim ws4 As Worksheet
> > Dim WsNew1 As Worksheet
> > Dim rng1 As Range
> > Dim rng2 As Range
> > Dim WB As Workbook
> >
> >
> >
> >
> >
> > 'Name of the sheet with your data
> > Set ws1 = Sheets("Rpt_BkgTrend") '<<< Change
> > Set ws3 = Sheets("Rpt_DepMth")
> >
> >
> > 'Determine the Excel version and file extension/format
> > If Val(Application.Version) < 12 Then
> > 'You use Excel 97-2003
> > FileExtStr = ".xls": FileFormatNum = -4143
> > Else
> > 'You use Excel 2007
> > If ws1.Parent.FileFormat = 56 Then
> > FileExtStr = ".xls": FileFormatNum = 56
> > Else
> > FileExtStr = ".xlsx": FileFormatNum = 51
> > End If
> > End If
> >
> > 'Set filter range : A9 is the top left cell of your filter range and
> > 'the header of the first column, V is the last column in the filter
> > range
> > Set rng = ws1.Range("A9:V" & Rows.Count)
> > Set rng1 = ws3.Range("A9:AE" & Rows.Count)
> >
> >
> > 'Set Field number of the filter column
> > 'Field:=1 is column A, 2 = column B, ......
> > FieldNum = 1
> >
> > With Application
> > CalcMode = .Calculation
> > .Calculation = xlCalculationManual
> > .ScreenUpdating = False
> > End With
> >
> > ' Add worksheet to copy/Paste the unique list
> > Set ws2 = Worksheets.Add
> >
> >
> > 'Fill in the path\folder where you want the new folder with the files
> > 'you can use also this "C:\Users\Ron\test"
> > MyPath = "C:\Documents and Settings\scchua\Desktop\Working"
> >
> > 'Add a slash at the end if the user forget it
> > If Right(MyPath, 1) <> "\" Then
> > MyPath = MyPath & "\"
> > End If
> >
> > 'Create folder for the new files
> > foldername = MyPath & Format(Now, "yyyy-mm-dd hh-mm-ss") & "\"
> > MkDir foldername
> >
> > With ws2
> > 'first we copy the Unique data from the filter field to ws2
> > rng.Columns(FieldNum).AdvancedFilter _
> > Action:=xlFilterCopy, _
> > CopyToRange:=.Range("A1"), Unique:=True
> > rng1.Columns(FieldNum).AdvancedFilter _
> > Action:=xlFilterCopy, _
> > CopyToRange:=.Range("A1000"), Unique:=True
> >
> > 'Replace value
> > Cells.Replace What:="Market", Replacement:="", LookAt:=xlPart, _
> > SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
> > ReplaceFormat:=False
> >
> > 'Sort data
> > ws2.Range("A1:A2000").Sort _
> > Key1:=ws2.Range("A1")
> >
> >
> > Set rng2 = ws2.Range("A1:A" & Rows.Count)
> > rng2.Columns(FieldNum).AdvancedFilter _
> > Action:=xlFilterCopy, _
> > CopyToRange:=.Range("B1"), Unique:=True
> >
> > Set rng3 = ws2.Range("B2:B" & Rows.Count)
> > rng3.Columns(FieldNum).AdvancedFilter _
> > Action:=xlFilterCopy, _
> > CopyToRange:=.Range("C1"), Unique:=True
> >
> > 'Loop for selected sheets
> > For i = 1 To Sheets.Count
> > If Mid(Sheets(i).Name, 1, 4) = ("Rpt_") Then
> >
> > 'loop through the unique list in ws2 and filter/copy to a new
> > workbook
> > Lrow = .Cells(Rows.Count, "C").End(xlUp).Row
> > For Each cell In .Range("C2:C" & Lrow)
> >
> > 'Add new workbook with 2 sheets
> >
> >
> >
> > Set WSNew = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
> > 'WSNew.Name = "Rpt_BkgTrend_Market"
> >
> >
> >
> > 'Firstly, remove the AutoFilter
> > ws1.AutoFilterMode = False
> > ws3.AutoFilterMode = False
> >
> >
> > 'Filter the range
> > rng.AutoFilter Field:=FieldNum, Criteria1:="=" & cell.Value
> > rng1.AutoFilter Field:=FieldNum, Criteria1:="=" & cell.Value
> >
> > 'Copy the Header 1 to 8
> > ws1.Rows("1:8").Copy
> > With WSNew.Range("A1")
> > .PasteSpecial Paste:=8
> > .PasteSpecial xlPasteValues
> > .PasteSpecial xlPasteFormats
> > End With
> >
> >
> > ws1.AutoFilter.Range.Copy
> > With WSNew.Range("A9")
> > ' Paste:=8 will copy the columnwidth in Excel 2000 and
> > higher
> > .PasteSpecial Paste:=8
> > .PasteSpecial xlPasteValues
> > .PasteSpecial xlPasteFormats
> > Application.CutCopyMode = False
> > .Select
> > End With
> >
> >
> > Application.CutCopyMode = False
> >
> >
> > 'Save the file in the new folder and close it
> > WSNew.Parent.SaveAs foldername & NewFn & "_" _
> > & cell.Value & FileExtStr, FileFormatNum
> > WSNew.Parent.Close False
> >
> >
> > 'Close AutoFilter
> > ws1.AutoFilterMode = False
> >
> >
> >
> > Next cell
> > End If
> > Next i
> >
> > 'Delete the ws2 sheet
> > On Error Resume Next
> > Application.DisplayAlerts = False
> > .Delete
> > Application.DisplayAlerts = True
> > On Error GoTo 0
> >
> > End With
> >
> >
> > MsgBox "Look in " & foldername & " for the files"
> >
> > With Application
> > .ScreenUpdating = True
> > .Calculation = CalcMode
> > End With
> >
> > End Sub
> >
> >
> >
> >
>
>
>
|
Similar Threads
