PDA

View Full Version : Solved: Problem Moving Data



PAB
12-05-2011, 05:32 PM
Good evening,

I have the code below that works when the data starts in cell “B3” in the “Input” sheet and goes down to cell “G whatever”. The last row changes on a regular basis but the columns will always be “B:G”.
Here is the code ...
Option Explicit
Sub Quadruples()

Dim rng As Range ' The entire range of ALL Lotto numbers drawn to date
Dim wsResult As Worksheet ' The sheet where ALL the calculated ouput resides
Dim lRow As Long ' Row in the [Results] sheet to start output from (NOT titles)
Dim c As Range ' Loop through the individual cells in the data range [rng]
Dim i As Integer ' Offset of 1 column in the [Input] sheet (column B)
Dim j As Integer ' Offset of 2 columns in the [Input] sheet (column C)
Dim k As Integer ' Offset of 3 columns in the [Input] sheet (column D)
Dim l As Integer ' Offset of 4 columns in the [Input] sheet (column E)
Dim m As Integer ' Offset of 5 columns in the [Input] sheet (column F)
Dim iSingle As Integer ' Combinations of 1 number
Dim strDouble As String ' Combinations of 2 numbers
Dim strTriplet As String ' Combinations of 3 numbers
Dim strQuadruple As String ' Combinations of 4 numbers
Dim strQuintuple As String ' Combinations of 5 numbers
Dim strSextuple As String ' Combinations of 6 numbers
Dim lRow2 As Long ' Total occurances output to the [Results] sheet ?

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False

Worksheets("Input").Select

' Store a reference to the [UsedRange] in the [Input] sheet
Set rng = Intersect(ActiveSheet.UsedRange, ActiveSheet.Range("B8:G" & ActiveSheet.Rows.Count))

' If there are NO draws in the [Input] sheet then [Exit Sub]
If rng Is Nothing Then
MsgBox "There is NO Draw Information to Process", vbInformation, "Warning"
Range("B3").Select
Exit Sub
End If

If Not rng Is Nothing Then

' Add [Results] sheet OR delete [UsedRange] if it already exists
On Error Resume Next
Set wsResult = ActiveWorkbook.Worksheets("Results")
If wsResult Is Nothing Then
Set wsResult = ActiveWorkbook.Worksheets.Add(After:=Worksheets("Input"))
' Format the WHOLE [Results] sheet as Tahoma
Cells.Font.Name = "Tahoma"
wsResult.Name = "Results"
Else
wsResult.UsedRange.Delete
End If

' Setup column titles (labels) in the [Results] sheet
With wsResult

' Quadruples
.Range("M2").Value = "String"
.Range("N2").Value = "n1"
.Range("N2").Font.Bold = True
.Range("O2").Value = "n2"
.Range("O2").Font.Bold = True
.Range("P2").Value = "n3"
.Range("P2").Font.Bold = True
.Range("Q2").Value = "n4"
.Range("Q2").Font.Bold = True
.Range("R2").Value = "Drawn"
.Range("R2").Font.Bold = True

End With
On Error GoTo 0

' Calculate and output ALL drawn Quadruples and the total times drawn
lRow = 3
For Each c In rng
For i = 1 To 7 - c.Column
For j = 1 To 7 - c.Offset(0, i).Column
For k = 1 To 7 - c.Offset(0, i + j).Column
strQuadruple = c.Value & "_" & _
c.Offset(0, i).Value & "_" & _
c.Offset(0, i + j).Value & "_" & _
c.Offset(0, i + j + k).Value

On Error Resume Next
lRow2 = Application.WorksheetFunction.Match(strQuadruple, wsResult.Range("M:M"), False)
If Err.Number > 0 Then
wsResult.Range("M" & lRow).Value = strQuadruple
wsResult.Range("N" & lRow).Value = c.Value
wsResult.Range("N" & lRow).NumberFormat = ("00")
wsResult.Range("O" & lRow).Value = c.Offset(0, i).Value
wsResult.Range("O" & lRow).NumberFormat = ("00")
wsResult.Range("P" & lRow).Value = c.Offset(0, i + j).Value
wsResult.Range("P" & lRow).NumberFormat = ("00")
wsResult.Range("Q" & lRow).Value = c.Offset(0, i + j + k).Value
wsResult.Range("Q" & lRow).NumberFormat = ("00")
wsResult.Range("R" & lRow).Value = 1
lRow = lRow + 1
Else
wsResult.Range("R" & lRow2).Value = wsResult.Range("R" & lRow2).Value + 1
End If
On Error GoTo 0
Next k
Next j
Next i
Next c


End If

Worksheets("Results").Select

With wsResult

.Columns("M").Clear

' Quadruples
Range("N2:R2").End(xlDown).Sort _
Key1:=Range("R2"), Order1:=xlDescending, Header:=xlYes, _
Key2:=Range("N2"), Order2:=xlAscending, Header:=xlYes, _
Key3:=Range("O2"), Order3:=xlAscending, Header:=xlYes

End With

Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

End Sub ... but when I move the data to start in cell "E8" and go down to cell "J whatever" I can't seem to get it to work
I don't know if it is the "Set rng" bit or setting the initial value of "c".
Thanks in advance.
PAB
:confused2

Bob Phillips
12-06-2011, 02:01 AM
I presume that you changed B8:G to E8:J?

You say it didn't work, what happens?

You also say in the text B3 down, but the code is B8. Which is correct?

Finally, can you post a workbook so we can try it?

PAB
12-06-2011, 10:13 AM
Hi xld,

Thanks for the reply.
I changed the original "B3:G" ("Input") to "E8:J" ("Input 1") and changed the original code accordingly which is attached in the Excel file.
The range in "Input 1" will get longer but will always be columns "E:J".

Thanks in advance.
PAB

PAB
12-06-2011, 01:49 PM
Hi xld,

I have been trying out different things and have found that if I insert "+ 3" like in the following piece of code it seems to work.
I would have thought that there would be a simpler resolution than this because it appears to still be using column "B" which is why the "+ 3" seems to work.
Is that correct?
Anyway, here is the piece of revised code ...



lRow = 3
For Each c In rng
For i = 1 To 7 - c.Column + 3
For j = 1 To 7 - c.Offset(0, i).Column + 3
For k = 1 To 7 - c.Offset(0, i + j).Column + 3

Thanks in advance,
PAB

p45cal
12-06-2011, 02:04 PM
try:Sub Calculate_Singles_Doubles_Triples_Quadruples_Quintuples_Sextuples()
Dim a As Long, b As Long, c As Long, d As Long
Dim rng As Range ' The entire range of ALL Lotto numbers drawn to date
Dim rw As Range ' a row of rng
Dim wsResult As Worksheet ' The sheet where ALL the calculated ouput resides
Dim lRow As Long ' Row in the [Results] sheet to start output from (NOT titles)
Dim iSingle As Integer ' Combinations of 1 number
Dim strDouble As String ' Combinations of 2 numbers
Dim strTriplet As String ' Combinations of 3 numbers
Dim strQuadruple As String ' Combinations of 4 numbers
Dim strQuintuple As String ' Combinations of 5 numbers
Dim strSextuple As String ' Combinations of 6 numbers
Dim lRow2 As Long ' Total occurances output to the [Results] sheet ?

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False

Worksheets("Input 1").Select

' Store a reference to the [UsedRange] in the [Input] sheet
Set rng = Intersect(ActiveSheet.UsedRange, ActiveSheet.Range("E8:J" & ActiveSheet.Rows.Count))

' If there are NO draws in the [Input] sheet then [Exit Sub]
If rng Is Nothing Then
MsgBox "There is NO Draw Information to Process", vbInformation, "Warning"
Range("B3").Select
Exit Sub
End If

If Not rng Is Nothing Then

' Add [Results] sheet OR delete [UsedRange] if it already exists
On Error Resume Next
Set wsResult = ActiveWorkbook.Worksheets("Results")
If wsResult Is Nothing Then
Set wsResult = ActiveWorkbook.Worksheets.Add(After:=Worksheets("Input 1"))
' Format the WHOLE [Results] sheet as Tahoma
Cells.Font.Name = "Tahoma"
wsResult.Name = "Results"
Else
wsResult.UsedRange.Delete
End If

' Setup column titles (labels) in the [Results] sheet
With wsResult

' Quadruples
.Range("M2").Value = "String"
.Range("N2").Value = "n1"
.Range("N2").Font.Bold = True
.Range("O2").Value = "n2"
.Range("O2").Font.Bold = True
.Range("P2").Value = "n3"
.Range("P2").Font.Bold = True
.Range("Q2").Value = "n4"
.Range("Q2").Font.Bold = True
.Range("R2").Value = "Drawn"
.Range("R2").Font.Bold = True

End With
On Error GoTo 0

' Calculate and output ALL drawn Quadruples and the total times drawn
lRow = 3
For Each rw In rng.Rows
For a = 1 To 3
For b = a + 1 To 4
For c = b + 1 To 5
For d = c + 1 To 6
'Debug.Print rw.Cells(a), rw.Cells(b), rw.Cells(c), rw.Cells(d)
strQuadruple = rw.Cells(a).Value & "_" & _
rw.Cells(b).Value & "_" & _
rw.Cells(c).Value & "_" & _
rw.Cells(d).Value
On Error Resume Next
lRow2 = Application.WorksheetFunction.Match(strQuadruple, wsResult.Range("M:M"), False)
If Err.Number > 0 Then
wsResult.Range("M" & lRow).Value = strQuadruple
wsResult.Range("N" & lRow).Value = rw.Cells(a).Value
wsResult.Range("N" & lRow).NumberFormat = ("00")
wsResult.Range("O" & lRow).Value = rw.Cells(b).Value
wsResult.Range("O" & lRow).NumberFormat = ("00")
wsResult.Range("P" & lRow).Value = rw.Cells(c).Value
wsResult.Range("P" & lRow).NumberFormat = ("00")
wsResult.Range("Q" & lRow).Value = rw.Cells(d).Value
wsResult.Range("Q" & lRow).NumberFormat = ("00")
wsResult.Range("R" & lRow).Value = 1
lRow = lRow + 1
Else
wsResult.Range("R" & lRow2).Value = wsResult.Range("R" & lRow2).Value + 1
End If
On Error GoTo 0
'Next d, c, b, a 'a shorter version of the 4 lines below
Next d
Next c
Next b
Next a
Next rw
End If

Worksheets("Results").Select

With wsResult
.Columns("M").Clear
' Quadruples
Range("N2:R2").End(xlDown).Sort _
Key1:=Range("R2"), Order1:=xlDescending, Header:=xlYes, _
Key2:=Range("N2"), Order2:=xlAscending, Header:=xlYes, _
Key3:=Range("O2"), Order3:=xlAscending, Header:=xlYes
End With

Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub

Now it doesn't matter where rng is as long as it's 6 columns wide.

PAB
12-06-2011, 04:41 PM
Hi p45cal,

It works like a dream, thank you for your time and effort.

All the very best,
PAB
:beerchug:

mdmackillop
12-06-2011, 04:48 PM
Hi PAB
Please use the green VBA button to format your code as shown, rather than Code tags.

PAB
12-06-2011, 05:16 PM
Hi MD,

Sorry, I will try and remember that in future.

All the best,
PAB

PAB
12-06-2011, 06:06 PM
Hi p45cal,

Just an extra question.
I applied the code to the actual data file and run it. It gave me several thousand extra counts at the top of the results. On testing why it did this I discovered it was because I have many rows below the last row of actual data that are formatted ready for future input. The results include these cells.
Is there any way that the "Set rng" can be adapted to only include the cells that have actual data in, this data will always be greater than zero.

Thanks in advance,
PAB

mdmackillop
12-06-2011, 06:12 PM
Look at SpecialCells to limit your range. (Too late here for a full answer!)

PAB
12-06-2011, 06:16 PM
Edit:
Although the actual data to use is in columns "E:J", the columns "B:E" has data in them, this doesn't seem to be a problem from what I can see, so It could possibly be only the cells underneath the actual data that are causing these extra results.

p45cal
12-06-2011, 06:28 PM
…or you could try the likes of:Dim lastr As Long
' Store a reference to the [UsedRange] in the [Input] sheet
lastr = Columns(5).Find(What:="*", LookIn:=xlValues, LookAt:= _
xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False _
, SearchFormat:=False).Row
Set Rng = ActiveSheet.Range("E8:J" & lastr)
perhaps choosing a column other than 5 (E).

PAB
12-06-2011, 06:44 PM
Hi p45cal,

That works great, thanks.
I will do some investigating to see if I can adapt it to only include cells that are greater than zero.

All the best,
PAB

PAB
12-06-2011, 06:58 PM
Hi p45cal, MD & xld,

I would just like to thank you all for your time and effort on this.

Kind regards,
PAB
:beerchug: