Counter to increment variable value - excel

I'm trying to name sheets based on the current date. I need a counter variable to name sheets so they're unique.
I made two attempts:
Sub COPIAR_MODELO()
Application.ScreenUpdating = False
Dim i As Integer, x As Integer
Dim shtname As String
Dim WSDummy As Worksheet
Dim TxtError As String
Dim counter As Long
counter = 0
Name01:
For counter = 1 To 100 Step 0
TxtError = ""
counter = counter + 1
shtname = Format(Now(), "dd mm yyyy") & " - " & counter
On Error Resume Next
Set WSDummy = Sheets(shtname)
If Not (WSDummy Is Nothing) Then TxtError = "Name taken, additional sheet added!"
Next counter
If TxtError <> "" Then MsgBox "" & TxtError: GoTo Name01
Sheets("MODELO - NFS").Copy Before:=Sheets("MODELO - DEMAIS"): ActiveSheet.Name = shtname
Application.ScreenUpdating = True
End Sub
Expected result:
And:
Sub COPIAR_MODELO()
Application.ScreenUpdating = False
Dim i As Integer, x As Integer
Dim shtname As String
Dim WSDummy As Worksheet
Dim TxtError As String
Dim counter As Long
TxtError = ""
shtname = Format(Now(), "dd mm yyyy")
On Error Resume Next
Set WSDummy = Sheets(shtname)
If Not (WSDummy Is Nothing) Then TxtError = "Name taken, additional sheet added!"
If TxtError <> "" Then MsgBox "" & TxtError: GoTo Name01
If TxtError = "" Then GoTo NameOK
Name01:
For counter = 1 To 100 Step 1
counter = counter + 1
shtname = Format(Now(), "dd mm yyyy") & " - " & counter
Next counter
NameOK:
Sheets("MODELO - NFS").Copy Before:=Sheets("MODELO - DEMAIS"): ActiveSheet.Name = shtname
Application.ScreenUpdating = True
End Sub
Expected result:
I will assign this code to a shape to create the sheets based on the current date.
I prefer result 2.

Copy Template
Sub CopyTemplate()
Const PROC_TITLE As String = "Copy Template"
Const TEMPLATE_WORKSHEET_NAME As String = "MODELO - NFS"
Const BEFORE_WORKSHEET_NAME As String = "MODELO - DEMAIS"
Const DATE_FORMAT As String = "dd mm yyyy"
Const DATE_NUMBER_DELIMITER As String = " - "
Const FIRST_NUMBER As Long = 2
Const FIRST_WORKSHEET_HAS_NUMBER As Boolean = False
Const INPUT_BOX_PROMPT As String = "Input number of worksheets to create."
Const INPUT_BOX_DEFAULT As String = "1"
Dim WorksheetsCount As String: WorksheetsCount _
= InputBox(INPUT_BOX_PROMPT, PROC_TITLE, INPUT_BOX_DEFAULT)
If Len(WorksheetsCount) = 0 Then Exit Sub
Dim DateName As String: DateName = Format(Date, DATE_FORMAT)
Dim NewName As String: NewName = DateName
Dim NewNumber As Long: NewNumber = FIRST_NUMBER
If FIRST_WORKSHEET_HAS_NUMBER Then
NewName = NewName & DATE_NUMBER_DELIMITER & NewNumber
NewNumber = NewNumber + 1
End If
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim wsTemplate As Worksheet
Set wsTemplate = wb.Worksheets(TEMPLATE_WORKSHEET_NAME)
Dim wsBefore As Worksheet
Set wsBefore = wb.Worksheets(BEFORE_WORKSHEET_NAME)
Dim wsNew As Worksheet
Dim WorksheetNumber As Long
Application.ScreenUpdating = False
Do While WorksheetNumber < WorksheetsCount
On Error Resume Next
Set wsNew = wb.Worksheets(NewName)
On Error GoTo 0
If wsNew Is Nothing Then
wsTemplate.Copy Before:=wsBefore
wsBefore.Previous.Name = NewName
WorksheetNumber = WorksheetNumber + 1
Else
NewName = DateName & DATE_NUMBER_DELIMITER & NewNumber
NewNumber = NewNumber + 1
Set wsNew = Nothing
End If
Loop
Application.ScreenUpdating = True
MsgBox WorksheetsCount & " worksheet" & IIf(WorksheetsCount = 1, "", "s") _
& " created.", vbInformation, PROC_TITLE
End Sub
If you overplay it...
Sub DeleteCreatedWorksheets()
Const PROC_TITLE As String = "Delete Created Worksheets"
Const BEFORE_WORKSHEET_NAME As String = "MODELO - DEMAIS"
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim wsBefore As Worksheet
Set wsBefore = wb.Worksheets(BEFORE_WORKSHEET_NAME)
Dim wsIndex As Long: wsIndex = wsBefore.Index - 1
If wsIndex > 0 Then
Application.DisplayAlerts = False
Dim n As Long
For n = wsIndex To 1 Step -1
wb.Worksheets(n).Delete
Next n
Application.DisplayAlerts = True
End If
MsgBox wsIndex & " created worksheet" _
& IIf(wsIndex = 1, "", "s") & " deleted.", _
vbInformation, PROC_TITLE
End Sub

Related

For each issue, run-time error 6, overflow

the below code is working perfectly but when i added the "'" code the code will stop after n number of loop related for each (rng1) giving an error of overflow run-time error 6
Appreciate if you can help me and if there is any possibility to optimize the code, thank you
the below code is working perfectly but when i added the "'" code the code will stop after n number of loop related for each (rng1) giving an error of overflow run-time error 6
Appreciate if you can help me and if there is any possibility to optimize the code, thank you
Sub Count()
Dim myPath As String
Dim myFile As String
Dim FldrPicker As FileDialog
Dim sh As Worksheet
Dim i As Integer
Dim j As Integer
Dim Count As Integer
Dim CountRecords As String
Dim FilePath As String
Dim UniquePercentage As Integer
Dim SumOfUniqueness As Integer
Dim CountOfUniqueness As Integer
Dim rng As Range
Dim rng1 As Range
Dim LastPosition As Integer
Set sh = ThisWorkbook.Sheets(1)
Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)
With FldrPicker
.Title = "Please Select Folder"
.AllowMultiSelect = False
.ButtonName = "Confirm"
If .Show = -1 Then
myPath = .SelectedItems(1) & "\"
Else
End
End If
End With
sh.Cells.ClearContents
myFile = Dir(myPath)
i = 1
Do While myFile <> ""
sh.Cells(1, 1) = "Table Name"
sh.Cells(i + 1, 1) = myFile
sh.Cells(1, 2) = "Count of records"
sh.Cells(1, 3) = "Uniqueness"
Count = Count + 1
myFile = Dir
i = i + 1
Loop
j = 1
For i = 1 To Count
sh.Activate
Worksheets(1).Activate
FilePath = myPath & Range("A" & j + 1).Value
Workbooks.Open FilePath
Worksheets("Properties").Activate
CountRecords = Sheets("Properties").Range("C15").Value
Worksheets("Column Profile").Activate
LastPosition = Range("D10").End(xlDown).Row - 2
For Each rng In Range("D10:D" & LastPosition)
rng.Value = Replace(rng, "-", "0")
rng.Value = CInt(rng)
Next rng
'For Each rng1 In Range("E10:E" & LastPosition)
'rng1.Value = Replace(rng1, "-", "0")
'rng1.Value = CInt(rng1)
'Next rng1
CountOfUniqueness = WorksheetFunction.CountIf(Range("E10:E" & LastPosition), 0)
SumOfUniqueness = WorksheetFunction.Sum(Range("D10:D" & LastPosition))
UniquePercentage = SumOfUniqueness / CountOfUniqueness
ActiveWorkbook.Close (False)
sh.Activate
Worksheets(1).Activate
Range("B" & j + 1).Value = CountRecords
Range("C" & j + 1).Value = UniquePercentage
j = j + 1
Next i
If i = 1 Then
MsgBox("There are no items in this folder:" & Dir(myPath))
End If
End Sub

VBA, data is not populating in new columns. Possible issue with Advanced Filter

We have added 5 new columns to three sheets in a workbook. The first sheet is like a staging table that then populates the other two. The problem is the new columns are not being populated with the data in the two final sheets. The data is visible in the intial sheet. I think it may be an issue with the Advanced Filter but im not sure. Any help would be appreciated.
Public Sub RunExtract()
Dim strExtractYear As String
Dim strExtractMonth As String
Dim strOutputFolder As String
Application.ScreenUpdating = False
'grab the control variable values
strExtractYear = Range("Extract_Year").Value
strExtractMonth = Range("Extract_Month").Value
strOutputFolder = Range("Output_Folder").Value
'pull the data
Application.StatusBar = "Pulling data..."
Call PullData(strExtractYear, strExtractMonth)
'filter and output the results
Application.StatusBar = "Extracting 310 summary data..."
Range("SummaryFilter.Criteria").Cells(2, 2).Formula = "=""=310"""
Call FilterData(Range("SalesExtract.Table"), Range("SummaryFilter.Criteria"), Range("SummaryFilter.Header"), "SummaryFilter.Table")
Call OutputResults("SUMMARY", "310", strOutputFolder)
Application.StatusBar = "Extracting 430 summary data..."
Range("SummaryFilter.Criteria").Cells(2, 2).Formula = "=""=430"""
Call FilterData(Range("SalesExtract.Table"), Range("SummaryFilter.Criteria"), Range("SummaryFilter.Header"), "SummaryFilter.Table")
Call OutputResults("SUMMARY", "430", strOutputFolder)
Application.StatusBar = "Extracting 310 detail data..."
Range("DetailFilter.Criteria").Cells(2, 2).Formula = "=""=310"""
Call FilterData(Range("SalesExtract.Table"), Range("DetailFilter.Criteria"), Range("DetailFilter.Header"), "DetailFilter.Table")
Call OutputResults("DETAIL", "310", strOutputFolder)
Application.StatusBar = "Extracting 430 detail data..."
Range("DetailFilter.Criteria").Cells(2, 2).Formula = "=""=430"""
Call FilterData(Range("SalesExtract.Table"), Range("DetailFilter.Criteria"), Range("DetailFilter.Header"), "DetailFilter.Table")
Call OutputResults("DETAIL", "430", strOutputFolder)
Call CleanUpThisWorkbook
Application.StatusBar = "Done"
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
Public Sub PullData(ExtractYear As String, ExtractMonth As String)
Dim conn As ADODB.Connection
Dim cmd As ADODB.Command
Dim rs As ADODB.Recordset
Dim strStartDate As String
Dim strStartDateTime As String
Dim strEndDateTime As String
Dim strYear As String
Dim strMonth As String
Dim strLastDay As String
'clear the existing range
Range("SalesExtract.Table").CurrentRegion.Offset(1).EntireRow.Delete
'figure out the start and end datetimes
strYear = ExtractYear
strMonth = Right("0" & ExtractMonth, 2)
strStartDate = "{year}-{month}-{day}"
strStartDate = Replace(strStartDate, "{year}", strYear)
strStartDate = Replace(strStartDate, "{month}", strMonth)
strStartDate = Replace(strStartDate, "{day}", "01")
strStartDateTime = strStartDate & " 00:00:00"
strLastDay = CStr(Day(DateSerial(Year(strStartDate), Month(strStartDate) + 1, 0)))
strEndDateTime = "{year}-{month}-{day} 23:59:59"
strEndDateTime = Replace(strEndDateTime, "{year}", strYear)
strEndDateTime = Replace(strEndDateTime, "{month}", strMonth)
strEndDateTime = Replace(strEndDateTime, "{day}", strLastDay)
Private Sub OutputResults(Level As String, Company As String, Directory As String)
Dim wb As Workbook
Set wb = Workbooks.Add
Dim strSheet As String
If Level = "SUMMARY" Then
strSheet = "SummaryFilter"
ElseIf Level = "DETAIL" Then
strSheet = "DetailFilter"
Else
'raise error
End If
Call ThisWorkbook.Worksheets(strSheet).Range(strSheet & ".Table").Copy
Call wb.Worksheets(1).Range("A1").PasteSpecial(xlPasteValues)
Call ThisWorkbook.Worksheets(strSheet).Range(strSheet & ".ReplacementHeader").Copy
Call wb.Worksheets(1).Range("A1").PasteSpecial(xlPasteValues)
wb.Worksheets(1).Name = Level & " " & Company
Application.DisplayAlerts = False
Call wb.SaveAs(Directory & "\Sales Extract - " & Level & " " & Company & ".xlsx")
Application.DisplayAlerts = True
Call wb.Close
Set wb = Nothing
End Sub
Private Sub FilterData(FilterRng As Range, CriteriaRng As Range, CopyToRng As Range, NameMe As String, Optional FilterUnique As Boolean)
With CopyToRng
If WorksheetFunction.CountA(.Offset(1, 0).Resize(1, .Columns.Count)) <> 0 Then
CopyToRng.CurrentRegion.Offset(1, 0).ClearContents
End If
End With
FilterRng.AdvancedFilter _
Action:=xlFilterCopy, _
CriteriaRange:=CriteriaRng, _
CopyToRange:=CopyToRng, _
Unique:=FilterUnique
CopyToRng.CurrentRegion.Name = NameMe
End Sub
Private Sub CleanUpThisWorkbook()
Range("SalesExtract.Table").Offset(1).EntireRow.Delete
Range("SummaryFilter.Table").Offset(1).EntireRow.Delete
Range("DetailFilter.Table").Offset(1).EntireRow.Delete
End Sub

VBA Set Print Area Based on Cell Reference

I put down together the following code. It basically loops through a path and converts all of the Excel workbooks into PDF.
I would like to setup the print area based on cell references. Cell C8 and D8
C8 = Column A - start of print area
D8 = Column M - end of print area
For example, I want the print area to start from column A - M. However, the current code prints everything, past column M
If settingsSheet.Range("C8").Value = vbNullString Or settingsSheet.Range("D8").Value = vbNullString Then
GoTo ABC
Else
reportColumnsAddr = settingsSheet.Range("C8").Value & ":" & settingsSheet.Range("D8").Value
Set reportSheet = Sheets(reportSheetName)
reportSheet.PageSetup.PrintArea = reportSheet.Columns(reportColumnsAddr).Address
End If
ABC:
Full code
Option Explicit
Private Sub CommandButton1_Click()
Dim MyFolder As String, MyFile As String
Dim StartTime As Double
Dim MinutesElapsed As String
Dim Filename As String
Dim Cell As String
Dim Counter As Long
If ThisWorkbook.Sheets("Sheet1").Range("C7").Value = vbNullString Then
MsgBox "Enter Tab Name"
Exit Sub
End If
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
.Title = "Select a Folder"
If .Show = True Then
MyFolder = .SelectedItems(1)
End If
If .SelectedItems.Count = 0 Then Exit Sub
Err.Clear
End With
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.EnableEvents = False
Application.Calculation = xlCalculationAutomatic
MyFile = Dir(MyFolder & "\", vbReadOnly)
StartTime = Timer
Do While MyFile <> ""
DoEvents
On Error GoTo 0
Workbooks.Open Filename:=MyFolder & "\" & MyFile, UpdateLinks:=False
Dim settingsSheet As Worksheet 'Source
Dim reportSheet As Worksheet 'To convert to PDF
Dim targetColumnsRange As Range 'feeds from source
Dim targetRowsRange As Range
Dim reportSheetName As String 'source sheet with the target's sheet name
Dim reportColumnsAddr As String
Dim reportRowsAddr As String
Dim WidthFit As String
Dim LengthFit As String
Set settingsSheet = ThisWorkbook.Worksheets("Sheet1") ' source
' Gather the report sheet's name
reportSheetName = settingsSheet.Range("C7").Value ' good
WidthFit = settingsSheet.Range("G8").Value
LengthFit = settingsSheet.Range("G9").Value
On Error Resume Next
Set reportSheet = Sheets(reportSheetName)
On Error GoTo 0
If reportSheet Is Nothing Then
MsgBox "No Sheet Named '" & reportSheetName & "' in This Workbook!"
Exit Sub
End If
If settingsSheet.Range("C8").Value = vbNullString Or settingsSheet.Range("D8").Value = vbNullString Then
GoTo ABC
Else
reportColumnsAddr = settingsSheet.Range("C8").Value & ":" & settingsSheet.Range("D8").Value
Set reportSheet = Sheets(reportSheetName)
reportSheet.PageSetup.PrintArea = reportSheet.Columns(reportColumnsAddr).Address
End If
ABC:
If WidthFit = "YES" Then
With reportSheet.PageSetup
.Zoom = False
.FitToPagesWide = 1
End With
End If
If LengthFit = "YES" Then
With reportSheet.PageSetup
.Zoom = False
.FitToPagesTall = 1
End With
End If
Filename = ActiveWorkbook.Name
Cell = Replace(Filename, ".xlsx", ".PDF")
reportSheet.Select
If settingsSheet.Range("J8").Value = "Landscape" Then
reportSheet.PageSetup.Orientation = xlLandscape
Else
reportSheet.PageSetup.Orientation = xlPortrait
End If
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
ThisWorkbook.Path & "\" & Cell, _
Quality:=xlQualityStandard, IncludeDocProperties:=True, _
IgnorePrintAreas:=True, OpenAfterPublish:=False
Counter = Counter + 1
0
Workbooks(MyFile).Close SaveChanges:=False
MyFile = Dir
Loop
Application.ScreenUpdating = True
Application.DisplayStatusBar = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
MinutesElapsed = Format((Timer - StartTime) / 86400, "hh:mm:ss")
MsgBox "Successfully Converted " & Counter & " Files in " & MinutesElapsed & " minutes", vbInformation
End Sub
Your error is you have set IgnorePrintAreas:=True, _ in reportSheet.ExportAsFixedFormat
That said, there are many other issues in your code:
Implicit ActiveWorkbook references
Unnecessary repetition of code in the loop
Case sensitive tests
Misleading variable names
Unnecessary use of GoTo
Malformed error handling
Could try to open non xlsx files
Incomplete checks of user Settings entry
Here's a refactor of your code
Private Sub CommandButton1_Click()
Dim MyFolder As String, MyFile As String
Dim StartTime As Double
Dim TimeElapsed As String
Dim Filename As String
Dim PdfFileName As String
Dim Counter As Long
Dim Orientation As XlPageOrientation
Dim settingsSheet As Worksheet 'Source
Dim reportSheet As Worksheet 'To convert to PDF
Dim targetColumnsRange As Range 'feeds from source
Dim targetRowsRange As Range
Dim reportSheetName As String 'source sheet with the target's sheet name
Dim reportColumnsAddr As String
Dim reportRowsAddr As String
Dim WidthFit As String
Dim LengthFit As String
Dim wb As Workbook
' Set a reference to the settings sheet
Set settingsSheet = ThisWorkbook.Worksheets("Sheet1") ' source
With settingsSheet
If .Range("C7").Value = vbNullString Then
MsgBox "Enter Tab Name"
Exit Sub
End If
If .Range("C8").Value = vbNullString Or .Range("D8").Value = vbNullString Then
MsgBox "Enter Valid Columns"
Exit Sub
End If
reportColumnsAddr = .Range("C8").Value & ":" & .Range("D8").Value
On Error Resume Next
Set targetColumnsRange = .Columns(reportColumnsAddr)
On Error GoTo 0
If targetColumnsRange Is Nothing Then
MsgBox "Enter Valid Columns"
Exit Sub
End If
Set targetColumnsRange = Nothing
reportSheetName = .Range("C7").Value ' good
WidthFit = .Range("G8").Value
LengthFit = .Range("G9").Value
Orientation = IIf(StrComp(.Range("J8").Value, "Landscape", vbTextCompare) = 0, xlLandscape, xlPortrait)
End With
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
.Title = "Select a Folder"
If .Show = True Then
MyFolder = .SelectedItems(1)
End If
If .SelectedItems.Count = 0 Then Exit Sub
Err.Clear
End With
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.EnableEvents = False
Application.Calculation = xlCalculationAutomatic
MyFile = Dir(MyFolder & "\*.xlsx", vbReadOnly)
StartTime = Timer()
Do While MyFile <> ""
DoEvents
On Error Resume Next
Set wb = Workbooks.Open(Filename:=MyFolder & "\" & MyFile, UpdateLinks:=False)
On Error GoTo 0
If wb Is Nothing Then
MsgBox "Failed to open " & MyFolder & "\" & MyFile
GoTo CleanUp
End If
Set reportSheet = Nothing
On Error Resume Next
Set reportSheet = wb.Worksheets(reportSheetName)
On Error GoTo 0
If reportSheet Is Nothing Then
MsgBox "No Sheet Named '" & reportSheetName & "' in This Workbook!"
GoTo CleanUp
End If
reportSheet.PageSetup.PrintArea = reportColumnsAddr
If StrComp(WidthFit, "YES", vbTextCompare) = 0 Then
With reportSheet.PageSetup
.Zoom = False
.FitToPagesWide = 1
End With
End If
If StrComp(LengthFit, "YES", vbTextCompare) = 0 Then
With reportSheet.PageSetup
.Zoom = False
.FitToPagesTall = 1
End With
End If
PdfFileName = Replace(wb.Name, ".xlsx", ".PDF")
reportSheet.PageSetup.Orientation = Orientation
reportSheet.ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=ThisWorkbook.Path & "\" & PdfFileName, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False
Counter = Counter + 1
wb.Close SaveChanges:=False
MyFile = Dir
Loop
CleanUp:
On Error Resume Next
wb.Close False
Application.ScreenUpdating = True
Application.DisplayStatusBar = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
TimeElapsed = Format((Timer() - StartTime) / 86400, "hh:mm:ss")
MsgBox "Successfully Converted " & Counter & " Files in " & TimeElapsed, vbInformation
End Sub

Excel VBA check if sheet exists and if yes add numeric to sheet name

I would like to say i'm an intermediate user of Excel VBA but i'm struggling with this one.
I have written a script to read a text file and strip out all the information I need and then add it to Worksheet that is named by the text file name and then todays date.
Set WS1 = ActiveWorkbook.Sheets("Home")
myFile = Application.GetOpenFilename()
myFileName = FileNameOf(myFile)
WS1.Copy After:=Sheets(Sheets.Count)
Set WS2 = ActiveSheet
strNewSheetName = myFileName & " - " & Format(Now, "DD-MM-YY")
blnSheetCheck = CheckIfSheetExists(strNewSheetName)
If blnSheetCheck = True Then
blnDeleteSheet = MsgBox("NOTICE:" & vbCrLf & vbCrLf & "This text file has already been added today!!" & vbCrLf & vbCrLf & "would you like to delete the existing one?", vbYesNo + vbCritical)
If blnDeleteSheet = vbYes Then
ActiveWorkbook.Sheets(strNewSheetName).Delete
WS2.Name = strNewSheetName
Else
' Roll the number here
End If
Else
WS2.Name = strNewSheetName
End If
I use this function to check if it exists
Function CheckIfSheetExists(SheetName) As Boolean
CheckIfSheetExists = False
Err.Clear
On Error Resume Next
Set WS99 = Sheets(SheetName)
If Err = 0 Then
CheckIfSheetExists = True
Else
CheckIfSheetExists = False
End If
End Function
When I first wrote the code I was going to add a time to the sheet name but it will sometimes push the name over the 31 character limit.
So I would like some guidance on how I can add a numeric to the end of the sheet name and then repeat the process to see if that sheet name exists and then move it up a number and then check again.
Thank you in advance
Andy
This will name the sheets as, for example:
Test 03-05-18 and then Test 03-05-18_01 up to Test 03-05-18_99.
Update this line to allow more copies:
TempShtName = SheetName & "_" & Format(lCounter, "00")
There's one procedure and two functions in the code:
The first is a copy of your code (with variables declare).
The second figures out the name of the sheet.
The third checks if the sheet exists.
Public Sub Test()
Dim WrkBk As Workbook
Dim WS1 As Worksheet, WS2 As Worksheet
Dim myFile As String
Dim myFileName As String
myFile = Application.GetOpenFilename()
'File name including extension:
'myFileName = Mid(myFile, InStrRev(myFile, "\") + 1)
'File name excluding extension:
myFileName = Mid(myFile, InStrRev(myFile, "\") + 1, InStrRev(myFile, ".") - InStrRev(myFile, "\") - 1)
With ThisWorkbook
Set WS1 = .Sheets("Home")
WS1.Copy After:=.Worksheets(.Worksheets.Count)
Set WS2 = .Worksheets(.Worksheets.Count)
WS2.Name = GetSheetName(myFileName & " - " & Format(Now, "dd-mm-yy"))
End With
End Sub
'Return a numbered sheet name (or the original if it's the first).
Public Function GetSheetName(SheetName As String, Optional WrkBk As Workbook) As String
Dim wrkSht As Worksheet
Dim TempShtName As String
Dim lCounter As Long
If WrkBk Is Nothing Then
Set WrkBk = ThisWorkbook
End If
TempShtName = SheetName
Do While WorkSheetExists(TempShtName)
lCounter = lCounter + 1
TempShtName = SheetName & "_" & Format(lCounter, "00")
Loop
GetSheetName = TempShtName
End Function
'Check if the sheet exists.
Public Function WorkSheetExists(SheetName As String, Optional WrkBk As Workbook) As Boolean
Dim wrkSht As Worksheet
If WrkBk Is Nothing Then
Set WrkBk = ThisWorkbook
End If
On Error Resume Next
Set wrkSht = WrkBk.Worksheets(SheetName)
WorkSheetExists = (Err.Number = 0)
Set wrkSht = Nothing
On Error GoTo 0
End Function
Edit:
To remove illegal characters and keep the sheet name to 31 characters you could add this code in the GetSheetName function just before the TempShtName = SheetName line:
Dim x As Long
Dim sChr As String
Const ILLEGAL_CHR As String = "\/*?:[]"
For x = 1 To Len(SheetName)
sChr = Mid(SheetName, x, 1)
If InStr(ILLEGAL_CHR, sChr) > 0 Then
SheetName = Replace(SheetName, sChr, "_")
End If
Next x
If Len(SheetName) > 28 Then
SheetName = Left(SheetName, 28)
End If
Set WS1 = ActiveWorkbook.Sheets("Home")
myFile = Application.GetOpenFilename()
myFileName = FileNameOf(myFile)
WS1.Copy After:=Sheets(Sheets.Count)
Set WS2 = ActiveSheet
strNewSheetName = myFileName & " - " & Format(Now, "DD-MM-YY")
blnSheetCheck = CheckIfSheetExists(strNewSheetName)
If blnSheetCheck = True Then
blnDeleteSheet = MsgBox("NOTICE:" & vbCrLf & vbCrLf & "This text file has already been added today!!" & vbCrLf & vbCrLf & "would you like to delete the existing one?", vbYesNo + vbCritical)
If blnDeleteSheet = vbYes Then
ActiveWorkbook.Sheets(strNewSheetName).Delete
WS2.Name = strNewSheetName
Else
'======Here's the new bit=================
Dim x as integer
x = 1
Do
strnewsheetname = left(strnewsheetname,30) & x
blnSheetCheck = CheckIfSheetExists(strNewSheetName)
x = x +1
Loop while blnSheetCheck
WS2.Name = strNewSheetName
'=============End of New Bit=============
End If
Else
WS2.Name = strNewSheetName
End If
Technically this will keep looping above 9, but from you've said I don't think this will be a problem

How to generate barcodes in excel worksheet

Just a short question, how to generate a barcode in excel worksheet? The barcode-text has been specified in a cell.
(Not intent to mass generate barcodes which otherwise can be done in MS Word.)
Select the range where barcode-text is written:
Then run the following script:
Sub INSERT_BARCODE()
Const BarcodeWidth As Integer = 156
Dim ws As Worksheet, WdApp
Set ws = ActiveSheet
Set WdApp = CreateObject("Word.Application")
With WdApp.Documents.Add
.PageSetup.RightMargin = .PageSetup.PageWidth - .PageSetup.LeftMargin - BarcodeWidth
.Fields.Add(Range:=.Range, Type:=-1, Text:="DISPLAYBARCODE " & CStr(Selection.Value) & " CODE39 \d \t", PreserveFormatting:=False).Copy
End With
ws.PasteSpecial Format:="Picture (Enhanced Metafile)", Link:=False, DisplayAsIcon:=False
WdApp.Quit SaveChanges:=False
Set WdApp = Nothing
End Sub
Note:
Change the encoding rule as you like. This example uses CODE39 rule. Refer https://msdn.microsoft.com/en-us/library/hh745901(v=office.12).aspx for more details.
Adjust the BarcodeWidth interger to best fit the barcode.
BR~
This is massively over-specced for what you need, but you can pull the bits out of it as required.
Sub Call_Barcode_Service()
Dim strResource As String
Dim strSize As String
Dim iHgt As Integer
Dim iWth As Integer
Dim iGap As Integer
Dim PictureGrab As String
Dim lngLastRow As Long
strSize = UCase(InputBox("How Big?", "Small, Medium or Large?", "L"))
Select Case strSize
Case Is = "S"
iWth = 150
iHgt = 45
iGap = 3
Case Is = "M"
iWth = 150
iHgt = 60
iGap = 4
Case Is = "L"
iWth = 240
iHgt = 75
iGap = 5
Case Else
iWth = 250
iHgt = 75
iGap = 5
End Select
Set sel = Selection.SpecialCells(xlTextValues)
Set news = Worksheets.Add()
news.Name = "Barcodes"
Set op = news.Range("A1")
For Each acc In sel
strResource = acc.Value
PictureGrab = "http://www.barcodesinc.com/generator/image.php?code=" & strResource & "&style=197&type=C128B&width=" & iWth & "&height=" & iHgt & "&xres=1&font=1"
Set sh = ActiveSheet.Shapes.AddShape(msoShapeRectangle, op.Left, op.Top, iWth, iHgt)
With sh
.Name = strResource
.Line.Visible = False
.Fill.UserPicture PictureGrab
End With
Set op = op.Offset(iGap + 1, 0).Range("A1")
Next
Range("G1").Select
End Sub
I use word with Macro :
Sub Macro1()
'
' Macro1 Macro
' Test Barcode
'
Dim codei As String
Dim codej As String
For I = 1 To 1 '0
For J = 1 To 2 '0
codei = CStr(I)
While Len(codei) < 2
codei = "0" & codei
Wend
codej = CStr(J)
While Len(codej) < 4
codej = "0" & codej
Wend
codei = codei & codej
Selection.Fields.Add Range:=Selection.Range, Type:=wdFieldEmpty, _
PreserveFormatting:=False
Selection.TypeText Text:="DisplayBarcode " & codei & " Code128 \t"
Selection.TypeParagraph
Selection.Fields.Update
Next J
Next I
End Sub

Resources