Home Menu

Menu


ExcelBanter » Excel Newsgroups » Excel Programming > Add sheet
Reply
 
LinkBack Thread Tools Search this Thread Display Modes
  #1   Report Post  
Posted to microsoft.public.excel.programming
jc jc is offline
external usenet poster
  
Posts: 164
Default Add sheet
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




Reply With QuoteReply With Quote
  #2   Report Post  
Posted to microsoft.public.excel.programming
external usenet poster
  
Posts: 10,593
Default Add sheet
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" wrote in message
...
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






Reply With QuoteReply With Quote
  #3   Report Post  
Posted to microsoft.public.excel.programming
jc jc is offline
external usenet poster
  
Posts: 164
Default Add sheet
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" wrote in message
...
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







Reply With QuoteReply With Quote
Reply
Thread Tools Search this Thread
Search this Thread:

Advanced Search
Display Modes
Linear Mode Linear Mode

Posting Rules
Smilies are On
[IMG] code is On
HTML code is Off
Trackbacks are On
Pingbacks are On
Refbacks are On

Similar Threads
Thread Thread Starter Forum Replies Last Post
excel sheet bootom half sheet goes behind top part of sheet rob Excel Worksheet Functions 2 January 17th 09 01:28 AM
Duplicate sheet, autonumber sheet, record data on another sheet des-sa[_2_] Excel Worksheet Functions 0 May 8th 08 06:56 PM
Export sheet store sheet import sheet. Robert[_33_] Excel Programming 0 December 28th 06 01:58 PM
relative sheet references ala sheet(-1)!B11 so I can copy a sheet. RonMc5 Excel Discussion (Misc queries) 9 February 3rd 05 12:51 AM
Inserting a row in sheet A should Insert a row in sheet B, removing a row in Sheet A should remove the corresponding row in sheet B Hannes Heckner Excel Programming 1 March 5th 04 09:10 AM


All times are GMT +1. The time now is 12:31 PM.

Powered by vBulletin® Copyright ©2000 - 2024, Jelsoft Enterprises Ltd.
Copyright ©2004-2024 ExcelBanter.
The comments are property of their posters.
 

About Us

"It's about Microsoft Excel"

 

Contact Us ExcelBanter forum home Privacy Statement