VBA filename append index

[buffyiscool]

Hi all.

I have created an SPC sheet which stores 120 spc measurements.
My code which checks each data column then updates the sheet is as follows:

Sub findemptycell()
    Application.ScreenUpdating = False

    'Check that all required fields are complete else stop and set focus to empty field
    Dim z As Control
    For Each z In UserForm1.Controls
        If TypeName(z) = "TextBox" Then
            If z.Name = "txtMAverage" Then GoTo continue
            If z.Name = "txtMeasAdjust" Then GoTo continue
            If z.Value = "" Then
                z.SetFocus
                Exit Sub
            End If
        End If
continue:
    Next z

    Dim xCell As Range
    Sheet1.Activate
    'see if any empty cells in 1st range of measurements b6 - b35
    Range("b6:b35").Select
    On Error Resume Next
    For Each xCell In Selection.Cells
        If Len(xCell) = 0 Then
            xCell.Select
            'line below checks that all 10 spc measures can be added to current column.
            If IsEmpty(ActiveCell.Offset(9, 0)) = False Then 
                GoTo 1
            Else
                GoTo update
            End If
        End If
    Next
1:        'see if any empty cells in 2nd range of measurements d6 - d35
    Range("D6:D35").Select
    On Error Resume Next
    For Each xCell In Selection.Cells
        If Len(xCell) = 0 Then
            xCell.Select
            If IsEmpty(ActiveCell.Offset(9, 0)) = False Then
                GoTo 2
            Else
                GoTo update
            End If
        End If
    Next
2:        'see if any empty cells in 3rd range of measurements f6 - f35
    Range("F6:F35").Select
    On Error Resume Next
    For Each xCell In Selection.Cells
        If Len(xCell) = 0 Then
            xCell.Select
            If IsEmpty(ActiveCell.Offset(9, 0)) = False Then
                GoTo 3
            Else
                GoTo update
            End If
        End If
    Next
3:        'see if any empty cells in 2nd range of measurements h6 - h35
    Range("H6:H35").Select
    On Error Resume Next
    For Each xCell In Selection.Cells
        If Len(xCell) = 0 Then
            xCell.Select
            If IsEmpty(ActiveCell.Offset(9, 0)) = False Then
                GoTo 4
            Else
                GoTo update
            End If
        End If
    Next
4:        'see if any empty cells in 2nd range of measurements j6 - j35
    Range("J6:J35").Select
    On Error Resume Next
    For Each xCell In Selection.Cells
        If Len(xCell) = 0 Then
            xCell.Select
            If IsEmpty(ActiveCell.Offset(9, 0)) = False Then
                GoTo 5
            Else
                GoTo update
            End If
        End If
    Next
5:
    MsgBox "Worksheet is full.", vbInformation + vbOKOnly, "Error"
    'make amendment to Job number (cell B3) here    
    'Exit Sub
update:
    Dim dnow As Date, tnow As Date, cno As String
    dnow = Format(Date, "dd mmm yyyy")
    tnow = Format(Now, "HH:mm:ss")
    cno = "'" + UserForm1.txtClockNo.Text
    Sheet2.Activate: Sheet2.Select
    Range("A1").Select
    Do Until IsEmpty(ActiveCell) = True
        ActiveCell.Offset(1, 0).Select
    Loop
    With ActiveCell
        .Value = dnow
        .Offset(0, 1).Value = tnow
        .Offset(0, 2).Value = cno
    End With
    Sheet1.Activate: Sheet1.Select
    Application.ScreenUpdating = True
    Return
    Exit Sub
End Sub

My problem is that some jobs will over-run the 130 measure capability of the sheet

The job number is a 7 digit number located in cell B3, so if the worksheet full message in the code above is triggered update the entry in cell B3 as detailed below.

a) if the currently opened file has original job number 1234567 in B3, then automatically append "(1) " to the end of the filename, eg. 1234567(1)
b) if the currently opened file has an appended job number,eg. 1234567(1) then increase that number by 1 eg. (1) will be updated to (2) etc.

An example of the sheet can be found at:
https://www.dropbox.com/s/cp869cclnf76uv9/2345678.pdf?dl=0

Hope this makes sense.

Is this possible and if so any help with this would be appreciated.

Thanks and regards
Colin

 

[JLGWhiz]

I am not sure I fully understand what you are doing. But if you insert this after your 'Sheet Full' message, it will change the job number in Range("B3").

With Sheet1
Dim rng As Range, sfx As Long
Set rng = Sheet1.Range("B3")
    If Len(.Range("B3").Value) = 7 Then
        .Range("B3") = .Range("B3").Value & "(1)"
    ElseIf Len(.Range("B3").Value) > 7 Then
        sfx = Mid(.Range("B3"), Len(Range("B3")) - 1, 1)
        .Range("B3") = Left(.Range("B3"), Len(.Range("B3")) - 2) & sfx + 1 & ")"
    End If
End With

As for change the file name, you can do that with a SaveAs statement, following the above With statement, since you would not want to do the SaveAs statement unless the Job Number changes

ActiveWorkbook.SaveAs Sheet1.Range("B3").Value & ".xlsm"

Assuming you will be running the code from the activeworkbook.

 

[buffyiscool]

Thanks JLGWhiz
I'll try out this code when I've got some spare time.
Regards
Colin

 

[JLGWhiz]

Thanks JLGWhiz
I'll try out this code when I've got some spare time.
Regards
Colin

You're welcome,
regards, JLG