Copy visible columns only from Excel worksheet as CSV file in VB6 without using copy command - vba

I have Excel worksheet object in which some columns are in invisible mode. I want to save those worksheets as CSV file with visible columns only. My primary requirement is not to use Copy method and csv file should contain all visible columns with value and format.
Private Sub SaveAsCSV_TSA(ByVal xl As Excel.Application, ByVal xlsheet As Excel.Worksheet, ByVal CSVSavePath As String)
On Error GoTo BottomLine
Set xlwbook1 = xl.Workbooks.Add
Dim xlsheet1 As Worksheet
Set xlsheet1 = xlwbook1.Sheets.Item(1)
xlsheet1.Activate
xlsheet.Cells.SpecialCells(xlCellTypeVisible).Copy
xlsheet1.Paste
xl.CutCopyMode = False
xlwbook1.SaveAs FileName:=CSVSavePath, FileFormat:=xlCSV
xlwbook1.Close SaveChanges:=False
Set xlwbook1 = Nothing
Set xlsheet1 = Nothing
BottomLine:
If Not xlsheet1 Is Nothing Then Set xlsheet1 = Nothing
If Not xlwbook1 Is Nothing Then Set xlwbook1 = Nothing
If Err.number > 0 And Err.number <> cdlCancel Then
MsgBox (Err.number & Chr(13) & Err.Description & " - Create_TS_Turn_file" & vbCrLf & "Line Number: " & Erl)
End If
End Sub
In the above case, xlsheet is a source, and xlsheet1 is a destination.
Note: Why I do not need to use copy command. Since, i have repeatedly calling the above method around (1000) times with different worksheet as parameter. (I have got the problem as cannot able to do other copy/paste work on the machine which this application runs. It causes that replace my original copied content with xlsheet.Cells.SpecialCells(xlCellTypeVisible).Copy content.
Please help me to resolve this.. I need to fix it soon. Thanks in advance!

edited as per OP's further specs
not so sure what's your issue but maybe this can help:
Option Explicit
Private Sub SaveAsCSV_TSA(ByVal xl As Excel.Application, ByVal xlsheet As Excel.Worksheet, ByVal CSVSavePath As String)
Dim xlwbook1 As Workbook
Dim xlsheet1 As Worksheet
Dim cell As Range
Dim colsAddr As String
On Error GoTo BottomLine
Set xlwbook1 = xl.Workbooks.Add
With xlwbook1
xlsheet.Copy After:=.Sheets.Item(1)
With .ActiveSheet '<~~ here starts the new "treatment"
With .UsedRange
For Each cell In .Rows(1).Cells '<~~ loop through first row cells
If cell.EntireColumn.Hidden Then colsAddr = colsAddr & cell.EntireColumn.Address & "," '<~~ store cell entire column address if hidden
Next cell
.Value = .Value '<~~ get rid of formulas and keep only their resulting values
End With
If colsAddr <> "" Then .Range(Left(colsAddr, Len(colsAddr) - 1)).Delete '<~~ delete hidden columns, if any
End With '<~~ here ends the new "treatment"
.SaveAs Filename:=CSVSavePath, FileFormat:=xlCSV
.Close SaveChanges:=False
End With
Set xlwbook1 = Nothing
Set xlsheet1 = Nothing
BottomLine:
If Not xlsheet1 Is Nothing Then Set xlsheet1 = Nothing
If Not xlwbook1 Is Nothing Then Set xlwbook1 = Nothing
If Err.Number > 0 And Err.Number <> xlCancel Then
MsgBox (Err.Number & Chr(13) & Err.Description & " - Create_TS_Turn_file" & vbCrLf & "Line Number: " & Erl)
End If
End Sub
which I suggest to call like follows
Sub main()
Application.ScreenUpdating = False '<~~ stop screen updating and speed things up
SaveAsCSV_TSA Application, ActiveSheet, "yourpath"
Application.ScreenUpdating = True '<~~ resume screen updating
End Sub

Related

VBA Loop not sending data to word in a consistent way

I have the below code that goes through a simple spreadsheet for now and paste the organisation,
one table a single cell value and a chart into a word template. The code runs and produces both a word and pdf version correctly. But what I see is that the table is on occasion ended up where the organisation should be and the chart is being repeated in the document. Each output of the loop seems to vary and I can't work out if the information is not being cleared from the clipboard before it gets pasted. Do I need to run the sections into sub sections or something?
Appreciate the help.
Sub CreateBasicWordReport()
Dim WdApp As Word.Application
Dim wdDoc As Word.Document
Dim SaveName As String
Dim FileExt As String
Dim LstObj1 As ListObject
Dim MaxValue As Integer
Dim FilterValue As Integer
Dim Organisation As String
Dim Rng As Range
Dim WS As Worksheet
Set LstObj1 = Worksheets("Sheet1").ListObjects("Table1")
MaxValue = WorksheetFunction.Max(LstObj1.ListColumns(1).Range)
FilterValue = MaxValue
Set WdApp = CreateObject("Word.Application")
Do Until FilterValue = 0
Application.DisplayAlerts = False
Sheets.Add(After:=Sheets("Sheet1")).Name = "Static"
Sheets("Sheet1").Select
'moved outside of loop
' Set WdApp = CreateObject("Word.Application")
With WdApp
.Visible = True
.Activate
'create new document and assign to object variable
Set wdDoc = .Documents.Add("C:\Users\david\Documents\Custom Office Templates\Template2.dotx")
'now mostly finished with WdApp as from here wdDoc is used
End With
ActiveSheet.ListObjects("Table1").Range.AutoFilter Field:=1, Criteria1:=FilterValue
Range("F11").Select
Range("A1", Range("A1").End(xlDown).End(xlToRight)).Copy
' .Selection.GoTo what:=-1, Name:="TableLocation"
' .Selection.Paste
wdDoc.Bookmarks("TableLocation").Range.Paste
For Each Row In Range("Table1[#All]").Rows
If Row.EntireRow.Hidden = False Then
If Rng Is Nothing Then Set Rng = Row
Set Rng = Union(Row, Rng)
End If
Next Row
Set WS = Sheets("Static")
Rng.Copy Destination:=WS.Range("A1")
' Sheets("Static").Select
' Sheets("Static").Activate
Organisation = WS.Range("D2").Value
' Sheets("Static").Select
' Range("D2").Copy
WS.Range("D2").Copy
' .Selection.GoTo what:=-1, Name:="Organisation"
' .Selection.PasteAndFormat wdFormatPlainText
wdDoc.Bookmarks("Organisation").Range.PasteAndFormat wdFormatPlainText
Application.CutCopyMode = False
' Sheets("Static").Select
' Range("F2").Copy
WS.Range("F2").Copy
' .Selection.GoTo what:=-1, Name:="MalePatients"
' .Selection.PasteAndFormat wdFormatPlainText
wdDoc.Bookmarks("MalePatients").Range.PasteAndFormat wdFormatPlainText
Application.CutCopyMode = False
Chart2.ChartArea.Copy
' .Selection.GoTo what:=-1, Name:="ChartLocation"
' .Selection.Paste
wdDoc.Bookmarks("ChartLocation").Range.Paste
If WdApp.Version <= 11 Then
FileExt = ".doc"
Else
FileExt = ".docx"
End If
SaveName = Environ("UserProfile") & "\Desktop\Report for " & _
Organisation & " " & _
Format(Now, "yyyy-mm-dd hh-mm-ss") & FileExt
If WdApp.Version <= 12 Then
' .ActiveDocument.SaveAs SaveName
wdDoc.SaveAs SaveName
Else
' .ActiveDocument.SaveAs2 SaveName
wdDoc.SaveAs2 SaveName
End If
SaveNamePDF = Environ("UserProfile") & "\Desktop\Report " & _
Organisation & " " & _
Format(Now, "yyyy-mm-dd hh-mm-ss") & ".pdf"
wdDoc.ExportAsFixedFormat _
OutputFileName:=SaveNamePDF, _
ExportFormat:=wdExportFormatPDF _
wdDoc.Close
FilterValue = FilterValue - 1
Sheets("Static").Delete
Application.DisplayAlerts = True
Loop
WdApp.Quit
Set WdApp = Nothing
End Sub
You may or may not want to take this as an answer to your question, but here are some ways you can improve your code so as to gain better control over how it operates. It is not a "solution" in the sense of a completed, correctly working code module, but if you adopt this advice it should enable you to solve the issue yourself (along with many other issues you might otherwise encounter in the future).
(1) Avoid using Copy and Paste. As you correctly note, those put you at the mercy of the Windows clipboard. Instead, assign the source object or value to a variable, then insert the contents of the variable at the destination. For instance:
Organisation = WS.Range("D2").Value
wdDoc.Bookmarks("Organisation").Range.Text = Organisation
Now you are able to control what is inserted at the destination point. Among other things, you can reset the variable at the end of each loop, so that there is no risk of repeatedly inserting an object or value that may be carried over from one loop cycle to the next.
(2) Use With ... End With to explicitly specify the parents of your objects. That way you don't risk accidentally referencing a different object than you expected. For instance, in this excerpt from your code ...
With WdApp
Set wdDoc = .Documents.Add("C:\Users\david\Documents\Custom Office Templates\Template2.dotx")
End With
Range("A1", Range("A1").End(xlDown).End(xlToRight)).Copy
... the range copied in the last line may not be what you expect. If the active object at the moment is your newly minted Word doc, the Range object may be interpreted as some range in the document, rather than the spreadsheet range you wanted to copy.
To stay in control, use With consistently:
With WdApp
Set wdDoc = .Documents.Add("C:\Users\david\Documents\Custom Office Templates\Template2.dotx")
End With
With MyWorkbook.Sheets("MySheet")
Set MyTableRange = .Range("A1", .Range("A1").End(xlDown).End(xlToRight))
End With
That's just a couple of pointers, but these are basic good coding practices that you should adopt. I think they will help you resolve the issues with your code.
The issues you are seeing are likely being caused by using the clipboard. There can be a delay when copying and pasting larger items, e.g. tables of data, charts.
When you use the clipboard you are passing some control over to the OS. VBA includes a function, DoEvents that passes control to the operating system. Control is then returned after the operating system has finished processing the events in its queue. By adding this after each copy/paste it should allow things to catch up.
You can also slightly reduce your use of the clipboard by setting the values for 'Organisation' and 'Male Patients' directly.
Sub CreateBasicWordReport()
Dim WdApp As Word.Application
Dim wdDoc As Word.Document
Dim SaveName As String
Dim FileExt As String
Dim LstObj1 As ListObject
Dim MaxValue As Integer
Dim FilterValue As Integer
Dim Organisation As String
Dim Rng As Range
Dim WS As Worksheet
Application.DisplayAlerts = False
Set LstObj1 = Worksheets("Sheet1").ListObjects("Table1")
MaxValue = WorksheetFunction.Max(LstObj1.ListColumns(1).Range)
FilterValue = MaxValue
Set WdApp = CreateObject("Word.Application")
Do Until FilterValue = 0
Sheets.Add(After:=Sheets("Sheet1")).Name = "Static"
Sheets("Sheet1").Select
With WdApp
.Visible = True
.Activate
'create new document and assign to object variable
Set wdDoc = .Documents.Add("C:\Users\david\Documents\Custom Office Templates\IBD Registry Quarterly Report Template2.dotx")
'now mostly finished with WdApp as from here wdDoc is used
End With
ActiveSheet.ListObjects("Table1").Range.AutoFilter Field:=1, Criteria1:=FilterValue
Range("F11").Select
Range("A1", Range("A1").End(xlDown).End(xlToRight)).Copy
wdDoc.Bookmarks("TableLocation").Range.Paste
DoEvents
For Each Row In Range("Table1[#All]").Rows
If Row.EntireRow.Hidden = False Then
If Rng Is Nothing Then Set Rng = Row
Set Rng = Union(Row, Rng)
End If
Next Row
Set WS = Sheets("Static")
Rng.Copy Destination:=WS.Range("A1")
Application.CutCopyMode = False
DoEvents
Organisation = WS.Range("D2").Value
wdDoc.Bookmarks("Organisation").Range.Text = Organisation
wdDoc.Bookmarks("MalePatients").Range.Text = WS.Range("F2").Text
Chart2.ChartArea.Copy
wdDoc.Bookmarks("ChartLocation").Range.Paste
DoEvents
Application.CutCopyMode = False
If CLng(WdApp.Version) <= 11 Then
FileExt = ".doc"
Else
FileExt = ".docx"
End If
SaveName = Environ("UserProfile") & "\Desktop\IBD Registry Quarterly Report for " & _
Organisation & " " & _
Format(Now, "yyyy-mm-dd hh-mm-ss")
SaveNamePDF = SaveName & ".pdf"
SaveName = SaveName & FileExt
If CLng(WdApp.Version) <= 12 Then
wdDoc.SaveAs SaveName
Else
wdDoc.SaveAs2 SaveName
End If
wdDoc.ExportAsFixedFormat _
OutputFileName:=SaveNamePDF, _
ExportFormat:=wdExportFormatPDF _
wdDoc.Close
FilterValue = FilterValue - 1
Sheets("Static").Delete
Application.DisplayAlerts = True
Loop
WdApp.Quit
Set WdApp = Nothing
End Sub

Excel VBA compare two workbooks write difference to text file

After much struggle with syntax, I have following code working, but I want to use error checking to determine if file is already open using a string.
(Disclosure: I have copied comparesheets from source that I will link when I find it)
Trying to replace this code
Set wbkA = Workbooks.Open(FileName:=wba)
with
Set wBook = Workbooks(wba) 'run time error subscript out of range
If wBook Is Nothing Then
Set wbkA = Workbooks.Open(FileName:=wba)
End If
But I have syntax problem with the string wba. What is proper way use string here?
Sub RunCompare_WS2()
Dim i As Integer
Dim wba, wbb As String
Dim FileName As Variant
Dim wkbA As Workbook
Dim wkbB As Workbook
Dim wBook As Workbook
wba = "C:\c.xlsm"
wbb = "C:\d.xlsm"
'Set wBook = Workbooks(FileName:=wba) 'compiler error named argument not found
'Set wBook = Workbooks(wba) 'run time error subscript out of range
'If wBook Is Nothing Then
'Set wbkA = Workbooks.Open(FileName:=wba)
'End If
Set wbkA = Workbooks.Open(FileName:=wba)
Set wbkB = Workbooks.Open(FileName:=wbb)
For i = 1 To Application.Sheets.Count
Call compareSheets(wbkA.Sheets(i), wbkB.Sheets(i))
Next i
wbkA.Close SaveChanges:=True
wbkB.Close SaveChanges:=False
MsgBox "Completed...", vbInformation
End Sub
Sub compareSheets(shtSheet1 As Worksheet, shtSheet2 As Worksheet)
Dim mycell As Range
Dim mydiffs As Integer
Dim DifFound As Boolean
DifFound = False
sDestFile = "C:\comp-wb.txt"
DestFileNum = FreeFile()
Open sDestFile For Append As DestFileNum
'For each cell in sheet2 that is not the same in Sheet1, color it lightgreen in first file
For Each mycell In shtSheet1.UsedRange
If Not mycell.Value = shtSheet2.Cells(mycell.Row, mycell.Column).Value Then
If DifFound = False Then
Print #DestFileNum, "Row,Col" & vbTab & vbTab & "A Value" & vbTab & vbTab & "B Value"
DifFound = True
End If
mycell.Interior.Color = 5296274 'LightGreen
Print #DestFileNum, mycell.Row & "," & mycell.Column, mycell.Value, shtSheet2.Cells(mycell.Row, mycell.Column).Value '& vbInformation
mydiffs = mydiffs + 1
End If
Next
Print #DestFileNum, mydiffs & " differences found in " & shtSheet1.Name
Close #DestFileNum
End Sub
You can use On Error Resume Next to ignore any error:
Const d As String = "C:\"
wba = "c.xlsm"
On Error Resume Next
Set wBook = Workbooks(wba)
On Error Goto 0
If wBook Is Nothing Then
Set wbkA = Workbooks.Open(d & wba) 'join string d & wba
End If
This will check to see if you have the file open.
Option Explicit
Function InputOpenChecker(InputFilePath) As Boolean
Dim WB As Workbook
Dim StrFileName As String
Dim GetFileName As String
Dim IsFileOpen As Boolean
InputOpenChecker = False
'Set Full path and name of file to check if already opened.
GetFileName = Dir(InputFilePath)
StrFileName = InputFilePath & GetFileName
IsFileOpen = False
For Each WB In Application.Workbooks
If WB.Name = GetFileName Then
IsFileOpen = True
Exit For
End If
Next WB
If you dont have it open, check to see if someone else does.
On Error Resume Next
' If the file is already opened by another process,
' and the specified type of access is not allowed,
' the Open operation fails and an error occurs.
Open StrFileName For Binary Access Read Write Lock Read Write As #1
Close #1
' If an error occurs, the document is currently open.
If Err.Number <> 0 Then
'Set the FileLocked Boolean value to true
FileLocked = True
Err.Clear
End If
And one reason for your error could be the inclusion of "FileName:=" in the Workbooks.Open. Try;
Set wbkA = Workbooks.Open(wba)
Set wbkB = Workbooks.Open(wbb)
Fixed my code and reposting with corrections for clarity.
Note I moved to C:\temp since writing to root C:\ folder should not be used because many work computers have root folder locked for security as my colleague just found out!
Sub RunCompare_WS9() 'compare two WKbooks, all sheets write diff to text file
Dim i As Integer
Dim wba, wbb As String
Dim FileName As Variant
Dim wkbA As Workbook
Dim wkbB As Workbook
Dim wbook1 As Workbook
Dim wbook2 As Workbook
wba = "C:\test\c.xlsm"
wbb = "C:\test\d.xlsm"
On Error Resume Next
Set wbook1 = Workbooks(wba)
On Error GoTo 0
If wbook1 Is Nothing Then
Set wbkA = Workbooks.Open(wba)
End If
On Error Resume Next
Set wbook2 = Workbooks(wbb)
On Error GoTo 0
If wbook2 Is Nothing Then
Set wbkB = Workbooks.Open(wbb)
End If
For i = 1 To Application.Sheets.Count
Call compareSheets(wbkA.Sheets(i), wbkB.Sheets(i))
Next i
wbkA.Close SaveChanges:=True
wbkB.Close SaveChanges:=False
MsgBox "Completed...", vbInformation
End Sub
Sub compareSheets(shtSheet1 As Worksheet, shtSheet2 As Worksheet)
Dim mycell As Range
Dim mydiffs As Integer
Dim DifFound As Boolean
DifFound = False
sDestFile = "C:\Test\comp2-wb.txt"
DestFileNum = FreeFile()
Open sDestFile For Append As DestFileNum
'For each cell in sheet2 that is not the same in Sheet1, color it lightgreen in first file
For Each mycell In shtSheet1.UsedRange
If Not mycell.Value = shtSheet2.Cells(mycell.Row, mycell.Column).Value Then
If DifFound = False Then
Print #DestFileNum, "Row,Col" & vbTab & vbTab & "A Value" & vbTab & vbTab & "B Value"
DifFound = True
End If
mycell.Interior.Color = 5296274 'LightGreen
Print #DestFileNum, mycell.Row & "," & mycell.Column, mycell.Value, shtSheet2.Cells(mycell.Row, mycell.Column).Value '& vbInformation
mydiffs = mydiffs + 1
End If
Next
Print #DestFileNum, mydiffs & " differences found in " & shtSheet1.Name
Close #DestFileNum
End Sub

VBA: Open file from cell then move to next cell

I currently have a list of files with the file path (C:/something.xlxs) in column B of a sheet. I want to write a Macro to read the value from the cell, open the file, and then move on to the next cell and open that file, etc.
I currently have this:
Sub openFiles()
Dim sFullName As String
Dim i As Integer
For i = 1 To 5
If Not IsEmpty(Cells(i, 2)) Then
sFullName = Cells(i, 2).Value
Workbooks.Open fileName:=Cells(i, 2).Value, UpdateLinks:=0
End If
Next i
End Sub
It is only opening the first file from the list and then stopping. It is probably a small error but I am having trouble spotting it.
Thanks
I would do it this way:
Sub openFiles()
Dim sFullName As String
Dim i As Integer
Dim wsh As Worksheet
On Error GoTo Err_openFiles
Set wsh = ThisWorkbook.Worksheets("Sheet1")
i = 1
Do While wsh.Range("B" & i)<>""
sFullName = wsh.Range("B" & i)
Application.Workbooks.Open sFullName, UpdateLinks:=False
i = i+1
Loop
Exit_openFiles:
On Error Resume Next
Set wsh = Nothing
Exit Sub
Err_openFiles:
MsgBox Err.Description, vbExclamation, Err.Number
Resume Exit_openFiles
End Sub
Above code works in context and provides a way to handle errors.
Try
Dim wb As Excel.Workbook
Set wb = Workbooks.Open(Filename:=sFullName)

Baffling Run-time error 91

I'm new to VBA, have searched all over the place but can't seem to find a solution. I'm
getting a Run-time error 91: Object variable or With block variable not set error. Does anyone know why?
Much thanks.
Option Explicit
Sub Survey()
'Name of the existing Word doc.
Const stCoHydroSurveyTemplate As String = "Survey Template.docx"
'Define Word objects.
Dim wdApp As Word.Application
Dim wdDoc As Word.Document
Dim wdbmHeadLossTable As Word.Range
Dim wdbmRevenueTable As Word.Range
'Define Excel objects.
Dim wbBook As Workbook
Dim wsSheet As Worksheet
Dim rnHeadLossTable As Range
Dim rnRevenueTable As Range
'Initialize the Excel objects.
Set wbBook = ThisWorkbook
Set wsSheet = wbBook.Worksheets("Sheet1")
Set rnHeadLossTable = wsSheet.Range("HeadLossTable")
Set rnRevenueTable = wsSheet.Range("RevenueTable")
'Initialize the Word objets.
Set wdApp = New Word.Application
Set wdDoc = wdApp.Documents.Open(wbBook.Path & "D:\Surveys" & stSurveyTemplate)
Set wdbmHeadLossTable = wdDoc.Bookmarks("HeadLossTable").Range
Set wdbmRevenueTable = wdDoc.Bookmarks("RevenueTable").Range
'If the macro has been run before, clean up any artifacts before trying to paste the table in again.
On Error Resume Next
With wdDoc.InlineShapes(1)
.Select
.Delete
End With
On Error GoTo 0
'Turn off screen updating.
Application.ScreenUpdating = False
'Copy the Head Loss Table to the clipboard.
rnHeadLossTable.Copy
rnRevenueTable.Copy
'Select the range defined by the "HeadLossTable" bookmark and paste in from the clipboard to the word doc "Survey Template".
With wdbmHeadLossTable
.Select
.PasteSpecial Link:=True, _
DataType:=wdPasteMetafilePicture, _
Placement:=wdInLine, _
DisplayAsIcon:=False
End With
With wdbmRevenueTable
.Select
.PasteSpecial Link:=True, _
DataType:=wdPasteMetafilePicture, _
Placement:=wdInLine, _
DisplayAsIcon:=False
End With
'Save and close the Word doc.
With wdDoc
.Save
.Close
End With
'Quit Word.
wdApp.Quit
'Null out your variables.
Set wdbmHeadLossTable = Nothing
Set wdbmRevenueTable = Nothing
Set wdDoc = Nothing
Set wdApp = Nothing
'Clear out the clipboard, and turn screen updating back on.
With Application
.CutCopyMode = False
.ScreenUpdating = True
End With
MsgBox "The Survey has successfully been " & vbNewLine & _
"transferred to " & stSurveyTemplate, vbInformation
End Sub
This line is incorrect:
Set wdDoc = wdApp.Documents.Open(wbBook.Path & "D:\Surveys" & stSurveyTemplate)
Maybe you meant for it to be like this:
Set wdDoc = wdApp.Documents.Open("D:\Surveys" & stSurveyTemplate)
or this:
Set wdDoc = wdApp.Documents.Open(wbBook.Path & "\Surveys" & stSurveyTemplate)
What I noticed is that with the original code, it didn't throw an error and wdDoc was just set to Nothing. I removed the "sbBook.Path" and by mistake had an incorrect file name, and that did throw an error.

Add new sheet to existing Excel workbook with VB code

This code creates an Excel file with one sheet. This sheet contains the code of an item like (ASR/Floor/Dept./Item_Name/Item_details/1) which I created and works fine, but I want to add a sheet into this Excel file to create another item code, and then save this file.
Dim xlApp As Excel.Application
Dim wb As Workbook
Dim ws As Worksheet
Dim var As Variant
Dim code As String
Dim i, nocode As Integer
Dim fname, heading As String
code = "ASR/" & Text1.Text & "/" & Text2.Text & "/" & Text3.Text & "/" & Text4.Text
Set xlApp = New Excel.Application
Set wb = xlApp.Workbooks.Add ' Create a new WorkBook
Set ws = wb.Worksheets("Sheet1") 'Specify your worksheet name
nocode = txtnocode.Text
heading = Text6.Text
For i = 2 To nocode + 1
ws.Cells(i, 1).Value = code & "/" & i - 1 '"ORG"
Next i
fname = "c:\" & Text5.Text & ".xls"
wb.SaveAs (fname)
wb.Close
xlApp.Quit
Set ws = Nothing
Set wb = Nothing
Set xlApp = Nothing
The Worksheets.Add method is what you are looking for:
wb.WorkSheets.Add().Name = "SecondSheet"
See MSDN(scroll down and expand Sheets and Worksheets) for the different parameters you can give to .Add including being able to add the sheet before or after a specific one.
Set ws = wb.Sheets("Sheet1")
Set ws = wb.Sheets.Add
ws.Activate
This is some standard code I use for this type of problem
Note: This code is VBA, to run from within the Excel document itself
Option Explicit
Private m_sNameOfOutPutWorkSheet_1 As String
Sub Delete_Recreate_TheWorkSheet()
On Error GoTo ErrorHandler
'=========================
Dim strInFrontOfSheetName As String
m_sNameOfOutPutWorkSheet_1 = "Dashboard_1"
strInFrontOfSheetName = "CONTROL" 'create the new worksheet in front of this sheet
'1] Clean up old data if it is still there
GetRidOf_WorkSheet_IfItExists (m_sNameOfOutPutWorkSheet_1)
CreateNewOutputWorkSheet m_sNameOfOutPutWorkSheet_1, strInFrontOfSheetName
'Color the tab of the new worksheet
ActiveWorkbook.Sheets(m_sNameOfOutPutWorkSheet_1).Tab.ColorIndex = 5
'Select the worksheet that I started with
Worksheets(strInFrontOfSheetName).Select
'=========================
Exit Sub
ErrorHandler:
Select Case Err.Number
Case Else
MsgBox "One_Main - Error: " & Err.Number & " " & Err.Description
End Select
End Sub
Sub GetRidOf_WorkSheet_IfItExists(sWorkSheetName_ForInitalData As String)
On Error GoTo ErrorHandler
'=========================
If fn_WorkSheetExists(sWorkSheetName_ForInitalData) Then
'Sheet Exists
Application.DisplayAlerts = False
Worksheets(sWorkSheetName_ForInitalData).Delete
Application.DisplayAlerts = True
End If
'=========================
Exit Sub
ErrorHandler:
Select Case Err.Number
Case Else
MsgBox "GetRidOf_WorkSheet_IfItExists - Error: " & Err.Number & " " & Err.Description
End Select
End Sub
Function fn_WorkSheetExists(wsName As String) As Boolean
On Error Resume Next
fn_WorkSheetExists = Worksheets(wsName).Name = wsName
End Function
Sub CreateNewOutputWorkSheet(sWorkSheetName_ForOutputData As String, strInFrontOfSheetName As String)
On Error GoTo ErrorHandler
'=========================
If fn_WorkSheetExists(sWorkSheetName_ForOutputData) Then
'Sheet Exists
Application.DisplayAlerts = False
Worksheets(sWorkSheetName_ForOutputData).Delete
Application.DisplayAlerts = True
End If
Dim wsX As Worksheet
Set wsX = Sheets.Add(Before:=Worksheets(strInFrontOfSheetName))
wsX.Name = sWorkSheetName_ForOutputData
'=========================
Exit Sub
ErrorHandler:
Select Case Err.Number
Case Else
MsgBox "CreateNewOutputWorkSheet - Error: " & Err.Number & " " & Err.Description
End Select
End Sub