VBA A1をA2に変更したい

質問

またお世話になります。
下記のはランダムにチーム分けするものです。
TmCnt = 5がチーム数です。
これはA1から氏名を読み取り、C1からランダムに表を作成するものです。
A2、C2に変更したいのです。
Data1 = Range("A1:A" & Total).Value　A1をA2に変えましたが、「インテックスが有効範囲にありません」とエラーメッセージが出ます。
どこが違うのでしょうか？
宜しくお願いします。

Sub Sample()
Dim Total As Integer
Dim TmCnt As Integer
Dim Data1 As Variant
Dim Data2() As String
Dim i As Integer, j As Integer, k As Integer

Total = Cells(Rows.Count, 1).End(xlUp).Row
TmCnt = 5
Data1 = Range("A1:A" & Total).Value
ReDim Data2(1 To Total)
Randomize

For i = TmCnt To 1 Step -1
j = Int(Rnd * i) + 1
Data2(i) = Data1(j, 1)
Data1(j, 1) = Data1(i, 1)
Next i
For i = Total To TmCnt + 1 Step -1
j = Int((i - (TmCnt + 1) + 1) * Rnd + TmCnt + 1)
Data2(i) = Data1(j, 1)
Data1(j, 1) = Data1(i, 1)
Next i

i = 1
Do
For j = 1 To TmCnt
k = k + 1
Cells(i, j + 2).Value = Data2(k)
If k = Total Then Exit Sub
Next j
i = i + 1
Loop
End Sub

回答No.4

kkkkkm · ベストアンサー

ReDim Data2(1 To Total)
Randomize

が抜けています。
No2を再度確認してください。

お礼

ありがとうございます。
うまくいきました。

回答No.3

kkkkkm

一部訂正です。

Total = WorksheetFunction.CountA(Range(Cells(FirstRow, 1), Cells(LastRow, 1)))
は
Total = LastRow - FirstRow + 1
に変更してください。
前者は連続してデータがある場合はいいのですが、途中空白があった場合最後のデータまで右の表に書き込めません。

お礼

ありがとうございます。
以下で動作しましたところ、「インテックスが有効範囲にありません」とエラーメッセージが出ます。どこが違うのでしょうか？
宜しくお願いします。

Sub sample()
Dim Total As Integer
Dim TmCnt As Integer
Dim Data1 As Variant
Dim Data2() As String
Dim i As Integer, j As Integer, k As Integer
Dim FirstRow As Long, LastRow As Long

FirstRow = 2
LastRow = Cells(Rows.Count, 1).End(xlUp).Row
Total = LastRow - FirstRow + 1
TmCnt = 5
Data1 = Range(Cells(FirstRow, 1), Cells(LastRow, 1)).Value

For i = TmCnt To 1 Step -1
j = Int(Rnd * i) + 1
Data2(i) = Data1(j, 1)
Data1(j, 1) = Data1(i, 1)
Next i
For i = Total To TmCnt + 1 Step -1
j = Int((i - (TmCnt + 1) + 1) * Rnd + TmCnt + 1)
Data2(i) = Data1(j, 1)
Data1(j, 1) = Data1(i, 1)
Next i

i = 1
Do
For j = 1 To TmCnt
k = k + 1
Cells(i, j + 2).Value = Data2(k)
If k = Total Then Exit Sub
Next j
i = i + 1
Loop
End Sub

回答No.2

kkkkkm

以下のようにしてください。

Sub Sample()
Dim Total As Integer
Dim TmCnt As Integer
Dim Data1 As Variant
Dim Data2() As String
Dim i As Integer, j As Integer, k As Integer
Dim FirstRow As Long, LastRow As Long

FirstRow = 2
LastRow = Cells(Rows.Count, 1).End(xlUp).Row
Total = WorksheetFunction.CountA(Range(Cells(FirstRow, 1), Cells(LastRow, 1)))
TmCnt = 5
Data1 = Range(Cells(FirstRow, 1), Cells(LastRow, 1)).Value

'↓ここから
'Total = Cells(Rows.Count, 1).End(xlUp).Row
' TmCnt = 5
' Data1 = Range("A1:A" & Total).Value
'↑ここまでを削除もしくはコメントにする

'↓ここから
ReDim Data2(1 To Total)
Randomize
'↑ここまでは元の部分で以下は変更なし

回答No.1

kkkkkm

Data1 = Range("A2:" & Total).Value
にしたことによりData1は19個になりました。
For i = Total To TmCnt + 1 Step -1
Totalは20なので
Data1(j, 1) = Data1(i, 1)
i=Totalの時にData1(20, 1)を指定したことになりエラーになっています。

最初の方を以下のようにしてFirstRow で最初の行を指定したほうがいいかもしれせん。
Dim FirstRow As Long, LastRow As Long

FirstRow = 2
LastRow = Cells(Rows.Count, 1).End(xlUp).Row
Total = WorksheetFunction.CountA(Range(Cells(FirstRow, 1), Cells(LastRow, 1)))
TmCnt = 5
Data1 = Range(Cells(FirstRow, 1), Cells(LastRow, 1)).Value

お礼

コメントありがとうございます。
すみませんが、最初の方を以下のようにとはどこからどこまででしょうか？