I have included the macro for you to see. The code that is not working,
Case, is near the end. As you can see there are more sheets involved but I
kept it to just trying to get R12 to function figuring I could expand after
the issue was resolved. R1 thru R12 sheets have to do the same thing. They
are mirrors of each other except for the name of the sheet. Thank you for
looking at this. I had to take out 41000 amount of text to be able to post
so there is the middle missing.
Option Explicit
Public Const WiseGuyVersion = "WiseGuy V.65" 'Input box heading
Sub A_Data1()
'
'Data1 Macro
'Macro recorded 08/07/2006 by User
'
'Keyboard Shortcut: Ctrl+q
'
'MSFT MVP, Windows Server - Networking, 2006
'MSFT MVP, Excel,2007'
'
'****************************************
'Beginning of user definable Const values
'****************************************
Const sourceSheet = "DataSorter" 'Source data sheet
Const R1 = "R1"
Const R2 = "R2"
Const R3 = "R3"
Const R4 = "R4"
Const R5 = "R5"
Const R6 = "R6"
Const R7 = "R7"
Const R8 = "R8"
Const R9 = "R9"
Const R10 = "R10"
Const R11 = "R11"
Const R12 = "R12"
Const firstColumnToCopy = "e" 'next is first column to copy, change to D
or E (or other) as needed
Const lastColumnToCopy = "S" 'next is last column to copy under normal
circumstances
Const KeyColumn = "C" 'note any used columns past lastColumnToCopy
will be copied anyhow,
'but changing it to go on out to known last
column will speed things up
'column on source sheet where the key/group
values are at/in
Const destStart = "q5" 'upper left corner on destination sheets for
starting paste operations
Const landingSpot = "a1" 'cell you want to be chosen on the R1 sheet
when all is done
Const pulledForInjury = 99.99 'value for entries where horse was pulled
for injury'
Const SaddleBlanket = "O5:O43"
'**********************************
'End of user definable Const values
'**********************************
Dim LastRow As Long
Dim lastColumn As Long ' prep for O2K7
Dim destSheet As String
Dim DPRO As Long ' Destination Page Row Offset
Dim SPCO As Long ' Source Page Column Offset
Dim DPCO As Long ' Destination Page Column Offset
Dim currentGroup As Integer
Dim LC As Long
Dim RC As Long
Dim dummyTest As Variant
Dim anySheet As Worksheet
Dim TestRow As Long
Dim Match As Variant
Dim I As Long
Dim InsertRows As Long
Dim CutOffDate As Date
Dim LastRowNumber As Long
Dim DeleteCount As Long
Dim dataOffset As Long
Dim thisSheetName As String
Dim anyRange As String
Dim shortestDistance As Single
Dim longestDistance As Single
Dim lousyFinish As Single
Dim lousyBeyer As Single
Dim raceonelength As String
Dim racetwolength As String
Dim racethreelength As String
Dim racefourlength As String
Dim racefivelength As String
Dim racesixlength As String
Dim racesevenlength As String
Dim raceeightlength As String
Dim raceninelength As String
Dim racetenlength As String
Dim raceelevenlength As String
Dim racetwelvelength As String
Dim Excel2007Flag As Boolean ' added in v11
Dim wb As Variant
Dim csvBook As Variant
'*********************************************************************************
'get csv sheet that is open and then get date from user if it needs to be
changed,
'default is 9 months prior to current system dat
'*********************************************************************************
For Each wb In Workbooks
If Right(wb.Name, 3) = "csv" Then csvBook = wb.Name
Next
Workbooks(csvBook).Sheets(1).Cells.Copy ActiveWorkbook.ActiveSheet.Cells
'******************************
' get cutoff date to keep
'******************************
CutOffDate = GetCutOffDate()
'******************************
' get shortest distance to keep
'******************************
shortestDistance = GetShortestDistance()
'****************************
'get longest distance to keep
'****************************
longestDistance = GetLongestDistance()
'****************************
'get lowest Beyer to keep
'****************************
lousyBeyer = GetLousyBeyer()
'****************************
'get best finish to keep
'****************************
lousyFinish = GetLousyFinish()
'****************************
'get race one length
'****************************
raceonelength = GetRaceLength(1)
'****************************
'get race two length
'****************************
racetwolength = GetRaceLength(2)
'****************************
'get race three length
'****************************
racethreelength = GetRaceLength(3)
'****************************
'get race four length
'****************************
racefourlength = GetRaceLength(4)
'****************************
'get race five length
'****************************
racefivelength = GetRaceLength(5)
'****************************
'get race six length
'****************************
racesixlength = GetRaceLength(6)
'****************************
'get race seven length
'****************************
racesevenlength = GetRaceLength(7)
'****************************
'get race eight length
'****************************
raceeightlength = GetRaceLength(8)
'****************************
'get race nine length
'****************************
raceninelength = GetRaceLength(9)
'****************************
'get race ten length
'****************************
racetenlength = GetRaceLength(10)
'****************************
'get race eleven length
'****************************
raceelevenlength = GetRaceLength(11)
'****************************
'get race twelve length
'****************************
racetwelvelength = GetRaceLength(12)
' continue uninterrupted
On Error GoTo 0
REMOVED
Worksheets("BetSheet").Select
Range("a1").Select
Worksheets("R12").Select
Range(landingSpot).Select
Worksheets("R11").Select
Range(landingSpot).Select
Worksheets("R10").Select
Range(landingSpot).Select
Worksheets("R9").Select
Range(landingSpot).Select
Worksheets("R8").Select
Range(landingSpot).Select
Worksheets("R7").Select
Range(landingSpot).Select
Worksheets("R6").Select
Range(landingSpot).Select
Worksheets("R5").Select
Range(landingSpot).Select
Worksheets("R4").Select
Range(landingSpot).Select
Worksheets("R3").Select
Range(landingSpot).Select
Worksheets("R2").Select
Range(landingSpot).Select
Worksheets("R1").Select
Range(landingSpot).Select
Worksheets(R12).Select
Select Case SaddleBlanket
Case Is = 1
Selection.Interior.ColorIndex = 3
Case Is = 2
Selection.Interior.ColorIndex = 2
Case Is = 3
Selection.Interior.ColorIndex = 41
Case Is = 4
Selection.Interior.ColorIndex = 6
Case Is = 5
Selection.Interior.ColorIndex = 50
Case Is = 6
Selection.Interior.ColorIndex = 1
Case Is = 7
Selection.Interior.ColorIndex = 46
Case Is = 8
Selection.Interior.ColorIndex = 7
Case Is = 9
Selection.Interior.ColorIndex = 42
Case Is = 10
Selection.Interior.ColorIndex = 13
Case Is = 11
Selection.Interior.ColorIndex = 48
Case Is = 12
Selection.Interior.ColorIndex = 4
End Select
Application.ScreenUpdating = True
Application.Cursor = xlDefault
On Error GoTo 0
End Sub
Private Sub DataReduction(anyColumn As String)
Dim anyRange As String
Dim LastRowNumber As Long
Dim dataOffset As Long
'v10.1a added back
Const CutOffValue = 1
Const FirstDataRow = "2"
'safety valve
If anyColumn = "" Then
Exit Sub
End If
If Val(Left(Application.Version, 2)) > 11 Then
If ActiveSheet.Cells(Rows.CountLarge, anyColumn).End(xlUp).Row >
LastRowNumber Then
LastRowNumber = ActiveSheet.Cells(Rows.CountLarge,
anyColumn).End(xlUp).Row
End If
Else
'for Excel versions prior to 2007 ("12.0")
If ActiveSheet.Cells(Rows.Count, anyColumn).End(xlUp).Row >
LastRowNumber Then
LastRowNumber = ActiveSheet.Cells(Rows.Count,
anyColumn).End(xlUp).Row
End If
End If
anyRange = anyColumn & FirstDataRow
'next safety valve - in case anyColumn had invalid column ID in it
On Error Resume Next
Range(anyRange).Select
If Err <> 0 Then
Err.Clear
On Error GoTo 0
Exit Sub ' no alert given
End If
dataOffset = 0 ' belt and suspenders, make sure dataoffset starts at zero
Do Until ActiveCell.Offset(dataOffset, 0) > CutOffValue Or
Range(anyRange).Row + dataOffset > LastRowNumber
If ActiveCell.Offset(dataOffset, 0) <= CutOffValue Then ' one or less
ActiveCell.Offset(dataOffset, 1).ClearContents ' column to the
right
End If
dataOffset = dataOffset + 1
Loop
End Sub
43) and run the code.