best method of bulk move of data?

[Ouka]

Hi all,

I have a spreadsheet that has 6 columns of data -- 1 record ID and 5
pieces of associated data. these rows of data are intermittently
interspereced with group identification rows like so:

(first ID starts in cell(14, 2))

Cohort 1
Id1 data1 data2 data3 data4 data5
Id2 data1 data2 data3 data4 data5
Id3 data1 data2 data3 data4 data5

cohort 2
Id4 data1 data2 data3 data4 data5
Id5 data1 data2 data3 data4 data5
Id6 data1 data2 data3 data4 data5

I need to quickly randomize this data (usually 300+ rows of data) based
on the IDs.

Unfortunatly the two ways I worked out (shown below) to do this are
*very* slow. I need something that goes much faster because I want to
loop the randomization process until certain criteria are met. Could
be as many as 500 or more re-randomizations.

Method 1: copy and paste of rows


Code:
--------------------

private sub cmdRandomize_click()
Dim lRow As Integer
lRow = ActiveSheet.Cells(Rows.Count, 2).End(xlUp).Row
Dim I As Integer
Dim X As Long
Dim Y As Long
Dim cohortCheck1 As Boolean
Dim cohortCheck2 As Boolean

For X = 14 To lRow

Randomize
Y = Int(Rnd * (lRow - 14) + 14)

If Y > 0 Then
cohortCheck1 = ActiveSheet.Cells(X, 2).value Like "*Cohort*"
cohortCheck2 = ActiveSheet.Cells(Y, 2).value Like "*Cohort*"

If cohortCheck1 = False And cohortCheck2 = False And _
ActiveSheet.Cells(X, 2) <> "" And ActiveSheet.Cells(Y, 2) <> "" Then
ActiveSheet.Cells(X, 2).Resize(1, 6).Copy
Paste (ActiveSheet.Cells(lRow + 5, 2))
ActiveSheet.Cells(Y, 2).Cells.Resize(1, 6).Copy
Paste (ActiveSheet.Cells(X, 2))
ActiveSheet.Cells(lRow + 5, 2).Resize(1, 6).Cut
Paste (ActiveSheet.Cells(Y, 2))
ElseIf cohortCheck1 = False And cohortCheck2 = True And _
ActiveSheet.Cells(X, 2) <> "" And ActiveSheet.Cells(Y, 2) <> "" Then
Y = Y + 1
ActiveSheet.Cells(X, 2).Resize(1, 6).Copy
Paste (ActiveSheet.Cells(lRow + 5, 2))
ActiveSheet.Cells(Y, 2).Cells.Resize(1, 6).Copy
Paste (ActiveSheet.Cells(X, 2))
ActiveSheet.Cells(lRow + 5, 2).Resize(1, 6).Cut
Paste (ActiveSheet.Cells(Y, 2))
End If
End If

Next X

End Sub
--------------------


This method is a bit clunky but it works. I was hoping that maybe if I
used variables instead of cut/paste that things would go faster as
follows:


Code:
--------------------

Private Sub cmdRandomize_Click()

Dim lRow As Integer
lRow = ActiveSheet.Cells(Rows.Count, 2).End(xlUp).Row
Dim I As Integer
Dim X As Long
Dim Y As Long
Dim tmp1 As Single
Dim tmp2 As Single
Dim tmp3 As Single
Dim tmp4 As Single
Dim tmp5 As Single
Dim tmp6 As Single
Dim cohortCheck1 As Boolean
Dim cohortCheck2 As Boolean

For X = 14 To lRow

Randomize
Y = Int(Rnd * (lRow - 14) + 14)

If Y > 0 Then
cohortCheck1 = ActiveSheet.Cells(X, 2).value Like "*Cohort*"
cohortCheck2 = ActiveSheet.Cells(Y, 2).value Like "*Cohort*"

If cohortCheck1 = False And cohortCheck2 = False And _
ActiveSheet.Cells(X, 2) <> "" And ActiveSheet.Cells(Y, 2) <> "" Then

tmp1 = ActiveSheet.Cells(X, 2).value
tmp2 = ActiveSheet.Cells(X, 3).value
tmp3 = ActiveSheet.Cells(X, 4).value
tmp4 = ActiveSheet.Cells(X, 5).value
tmp5 = ActiveSheet.Cells(X, 6).value
tmp6 = ActiveSheet.Cells(X, 7).value

ActiveSheet.Cells(X, 2).value = ActiveSheet.Cells(Y, 2).value
ActiveSheet.Cells(X, 3).value = ActiveSheet.Cells(Y, 3).value
ActiveSheet.Cells(X, 4).value = ActiveSheet.Cells(Y, 4).value
ActiveSheet.Cells(X, 5).value = ActiveSheet.Cells(Y, 5).value
ActiveSheet.Cells(X, 6).value = ActiveSheet.Cells(Y, 6).value
ActiveSheet.Cells(X, 7).value = ActiveSheet.Cells(Y, 7).value

ActiveSheet.Cells(Y, 2).value = tmp1
ActiveSheet.Cells(Y, 3).value = tmp2
ActiveSheet.Cells(Y, 4).value = tmp3
ActiveSheet.Cells(Y, 5).value = tmp4
ActiveSheet.Cells(Y, 6).value = tmp5
ActiveSheet.Cells(Y, 7).value = tmp6

ElseIf cohortCheck1 = False And cohortCheck2 = True And _
ActiveSheet.Cells(X, 2) <> "" And ActiveSheet.Cells(Y, 2) <> "" Then
Y = Y + 1

tmp1 = ActiveSheet.Cells(X, 2).value
tmp2 = ActiveSheet.Cells(X, 3).value
tmp3 = ActiveSheet.Cells(X, 4).value
tmp4 = ActiveSheet.Cells(X, 5).value
tmp5 = ActiveSheet.Cells(X, 6).value
tmp6 = ActiveSheet.Cells(X, 7).value

ActiveSheet.Cells(X, 2).value = ActiveSheet.Cells(Y, 2).value
ActiveSheet.Cells(X, 3).value = ActiveSheet.Cells(Y, 3).value
ActiveSheet.Cells(X, 4).value = ActiveSheet.Cells(Y, 4).value
ActiveSheet.Cells(X, 5).value = ActiveSheet.Cells(Y, 5).value
ActiveSheet.Cells(X, 6).value = ActiveSheet.Cells(Y, 6).value
ActiveSheet.Cells(X, 7).value = ActiveSheet.Cells(Y, 7).value

ActiveSheet.Cells(Y, 2).value = tmp1
ActiveSheet.Cells(Y, 3).value = tmp2
ActiveSheet.Cells(Y, 4).value = tmp3
ActiveSheet.Cells(Y, 5).value = tmp4
ActiveSheet.Cells(Y, 6).value = tmp5
ActiveSheet.Cells(Y, 7).value = tmp6
End If
End If

Next X

Call averagesFormat

End Sub
--------------------


But unfortunarly this is even slower than the cut/paste method.

Is there *any* other way to achieve my goal here? I have to randomize
the data until each of the cohorts have standard deviations, means, and
medians fall withing certain ranges for each of the 5 data points. I
have all that written out already, but using the randomization routines
above means the user hits "Randomize" and then walks away for a half
hour or more. Not ideal.

 

[Ouka]

I should note that turning off screen updating during the randomization
process does significantly improve performance, but not enough....

 

[Toppers]

Hi,
Try this which stores data in in-core array:

Sub cmdRandomize_Click()

Dim lRow As Integer

Dim I As Integer
Dim X As Long
Dim Y As Long
Dim tmp

Dim cohortCheck1 As Boolean
Dim cohortCheck2 As Boolean

Dim v As Variant

lRow = ActiveSheet.Cells(Rows.Count, 2).End(xlUp).Row

v = ActiveSheet.Range("b2:G2" & lRow)


For X = LBound(v, 1) To UBound(v, 1)

Randomize
Y = Int(Rnd * (lRow - 14) + 14)

If Y > 0 Then

cohortCheck1 = Left(v(X, 2), 6) = "Cohort"
cohortCheck2 = Left(v(Y, 2), 6) = "Cohort"

If cohortCheck1 = False And cohortCheck2 = False And _
v(X, 2) <> "" And v(Y, 2) <> "" Then
For j = LBound(v, 2) To UBound(v, 2)
tmp = v(X, j)
v(X, j) = v(Y, j)
v(Y, j) = tmp
Next j


Else
If cohortCheck1 = False And cohortCheck2 = True And _
v(X, 2) <> "" And v(Y, 2) <> "" Then
Y = Y + 1

For j = LBound(v, 2) To UBound(v, 2)
tmp = v(X, j)
v(X, j) = v(Y, j)
v(Y, j) = tmp
Next j

End If
End If
End If

Next X

ActiveSheet.Range("b2:G2" & lRow) = v

Call averagesFormat

End Sub

 

[Toppers]

Hi again,
Spotted some typos (although it did work OK or so I
thought):

v = ActiveSheet.Range("B14:G" & lRow)

Y = Int(Rnd * (lRow - 14) + 1)

ActiveSheet.Range("B14:G" & lRow)=v

Apologies!