frogman
07-13-2016, 04:06 AM
I found this on here and need some help. I am using this Macro to copy a sheet and when it copies the tab number increments for example from Game#25 to Game#26. The problem I am having is when I get into the 1000's for a Game# it does not increment and it does something like this Game#1005, Game#1005-1, Game#1005-2. What can I change in the Macro to correct this? Also is there a way when it copies an Even number tab it makes it green and an odd number tab it makes it red?
Thank you for your help
Sub Copy_Me()
Const mycolumns = "A,C,D,E,F,L,N,O,P,Q,W,Y,Z,AA,AB"
Dim tmp As String, num As Long, i As Long, j As Long, minus1 As Boolean, finalbracket As Boolean, skipped As Long, adr As String, col, whereerrors As String
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False
ActiveSheet.Copy After:=Sheets(Sheets.Count)
tmp = Replace(ActiveSheet.Name, " (2)", "")
num = InStrRev(tmp, " ")
On Error Resume Next
ActiveSheet.Name = Left(tmp, num) & 1 + Mid(tmp, num + 1)
' If Err.Number <> 0 Then MsgBox "Please check created sheet name!", vbCritical
On Error GoTo 0
Range("B25").Value = Range("B25").Value + 1
col = Split(mycolumns, ",")
For j = LBound(col) To UBound(col)
For i = 3 To 35
If Cells(i, col(j)).HasFormula Then
tmp = Cells(i, col(j)).Formula
If Right(tmp, 1) = ")" Then
finalbracket = True
tmp = Left(tmp, Len(tmp) - 1)
Else
finalbracket = False
End If
If Right(tmp, 2) = "-1" Then
minus1 = True
tmp = Left(tmp, Len(tmp) - 2)
Else
minus1 = False
End If
num = InStrRev(tmp, "!")
On Error Resume Next
adr = Range(Mid(tmp, num + 1)).Offset(-1, 0).Address(False, False)
If Err.Number <> 0 Then
skipped = skipped + 1
whereerrors = whereerrors & ", " & Cells(i, col(j)).Address
Else
Cells(i, col(j)).Formula = Left(tmp, num) & adr & IIf(minus1, "-1", "") & IIf(finalbracket, ")", "")
End If
On Error GoTo 0
End If
Next i
Next j
If skipped <> 0 Then MsgBox "Please check formulas!" & vbNewLine & "probably there are errors in " & skipped & " of them." & wbnewline & Mid(whereerrors, 3), vbCritical
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
Application.Calculate
End Sub
Sub make_10_consequtive_copies()
Dim i As Integer
For i = 1 To 10
Call Copy_Me
Next i
End Sub
Incorrect
16609
correct
16610
Thank you for your help
Sub Copy_Me()
Const mycolumns = "A,C,D,E,F,L,N,O,P,Q,W,Y,Z,AA,AB"
Dim tmp As String, num As Long, i As Long, j As Long, minus1 As Boolean, finalbracket As Boolean, skipped As Long, adr As String, col, whereerrors As String
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False
ActiveSheet.Copy After:=Sheets(Sheets.Count)
tmp = Replace(ActiveSheet.Name, " (2)", "")
num = InStrRev(tmp, " ")
On Error Resume Next
ActiveSheet.Name = Left(tmp, num) & 1 + Mid(tmp, num + 1)
' If Err.Number <> 0 Then MsgBox "Please check created sheet name!", vbCritical
On Error GoTo 0
Range("B25").Value = Range("B25").Value + 1
col = Split(mycolumns, ",")
For j = LBound(col) To UBound(col)
For i = 3 To 35
If Cells(i, col(j)).HasFormula Then
tmp = Cells(i, col(j)).Formula
If Right(tmp, 1) = ")" Then
finalbracket = True
tmp = Left(tmp, Len(tmp) - 1)
Else
finalbracket = False
End If
If Right(tmp, 2) = "-1" Then
minus1 = True
tmp = Left(tmp, Len(tmp) - 2)
Else
minus1 = False
End If
num = InStrRev(tmp, "!")
On Error Resume Next
adr = Range(Mid(tmp, num + 1)).Offset(-1, 0).Address(False, False)
If Err.Number <> 0 Then
skipped = skipped + 1
whereerrors = whereerrors & ", " & Cells(i, col(j)).Address
Else
Cells(i, col(j)).Formula = Left(tmp, num) & adr & IIf(minus1, "-1", "") & IIf(finalbracket, ")", "")
End If
On Error GoTo 0
End If
Next i
Next j
If skipped <> 0 Then MsgBox "Please check formulas!" & vbNewLine & "probably there are errors in " & skipped & " of them." & wbnewline & Mid(whereerrors, 3), vbCritical
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
Application.Calculate
End Sub
Sub make_10_consequtive_copies()
Dim i As Integer
For i = 1 To 10
Call Copy_Me
Next i
End Sub
Incorrect
16609
correct
16610