I used this macro for many months with no problem; I delete all data I reinsert new data then when I run the macro it delete all data reinsert before.
Please, help me in fix the problem with macro.
Next, show the macro.
Please, help me in fix the problem with macro.
Next, show the macro.
Code:
Sub BallSet()
max_tabs = Worksheets.Count
For Tabs = 2 To max_tabs
With Sheets(Tabs)
y_max = .Cells(Rows.Count, 1).End(xlUp).Row
If y_max > 1 Then
.Activate
.Range("A2:H" & y_max).ClearContents
End If
End With
Next Tabs
With Sheets("data")
.Select
y_max = .Cells(Rows.Count, 1).End(xlUp).Row
For y = 3 To y_max Step 2
Acol = .Cells(y, 1)
If IsDate(Acol) Then
Bcol = .Cells(y, 2)
Ccol = .Cells(y, 3)
On Error Resume Next
Ntab = WorksheetFunction.Find(Bcol, "ABCDEF", 1)
If Err.Number = 0 Then
Ntab = Ntab + 1
With Worksheets(Ntab)
yy = .Cells(Rows.Count, 1).End(xlUp).Row + 1
If yy < 1 Then yy = 2
.Cells(yy, 1) = Acol
.Cells(yy, 1).NumberFormat = "mmm-dd, yyyy"
.Cells(yy, 2) = Bcol
For x = 3 To 8
.Cells(yy, x) = Mid(Ccol, 1 + (x - 3) * 3, 2)
Next x
End With
End If
End If
Next y
End With
ans = MsgBox("Ready")
End Sub
Sub OLD_BallSet()
Application.ScreenUpdating = False
Sheets("Data").Activate
Sheets("Data").Columns("J:L").ClearContents
max_tabs = Worksheets.Count
y = 1
For Tabs = 2 To max_tabs
yy = 2
Do
If Sheets(Tabs).Cells(yy, 1) <> Empty Then
For x = 1 To 3
Sheets("data").Cells(y, 9 + x) = Sheets(Tabs).Cells(yy, x)
Next x
y = y + 1
End If
yy = yy + 1
Loop Until Sheets(Tabs).Cells(yy, 1) = Empty
Next Tabs
Sheets("data").Sort.SortFields.Clear
Sheets("data").Sort.SortFields.Add Key:=Range("J1:J" & y - 1), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With Sheets("data").Sort
.SetRange Range("J1:L" & y - 1)
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
With Sheets("data")
prev_year = -1
y = 1
yy = 1
If .Cells(yy, 10) = Empty Then Exit Sub
With .Columns("A:H")
.ClearContents
.UnMerge
.Interior.ColorIndex = xlNone
With .Font
.Underline = xlNone
.Bold = True
.Size = 7
End With
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
Do
If Year(.Cells(yy, 10)) <> prev_year Then
.Cells(y, 1) = "Date"
.Cells(y, 2) = "Ballset"
.Cells(y, 3) = "Numbersdrawn"
.Cells(y + 1, 1) = "year"
.Cells(y + 1, 2) = Year(.Cells(yy, 10))
.Range(.Cells(y, 3), .Cells(y, 8)).Merge
With .Range(.Cells(y, 1), .Cells(y + 1, 8))
.Interior.ColorIndex = 6
.Font.Underline = xlUnderlineStyleSingle
End With
prev_year = .Cells(y + 1, 2)
y = y + 2
End If
.Cells(y, 1) = Format(.Cells(yy, 10), "mmm-dd")
.Cells(y, 1).NumberFormat = "@"
.Cells(y, 2) = .Cells(yy, 11)
For x = 3 To 8
.Cells(y, x) = Mid(.Cells(yy, 12), 1 + (x - 3) * 3, 2)
.Cells(y, x).NumberFormat = "00"
Next x
.Cells(y + 1, 1) = Format(.Cells(yy, 10), "mmm-dd")
.Cells(y + 1, 1).NumberFormat = "@"
y = y + 2
yy = yy + 1
Loop Until .Cells(yy, 10) = Empty
.Columns("J:L").ClearContents
.Range("I3").Select
End With
End Sub
Last edited by a moderator:
