ExcelのVBAに詳しい人に質問です

質問

下記のURL画像のような表があります。
http://www.poverty.jeez.jp/ura/img/kenmou01000.png

A列に入っている１～62までの文字（画像ではわかりやすく数字にしています。）を、右の表の番号をふっている箇所に順番通りに挿入するVBAを組みたいのですが、どのような書き方が1番効率的なのでしょうか。
例えば、一つ一つやるなら62列も一々打つことになるので手間がかかってしまいます（；´Д｀）

Range("B5").Value = Range("A1").Value
Range("C5").Value = Range("A2").Value
Range("D5").Value = Range("A3").Value

何か良い方法はありますでしょうか。数学が出来ない馬鹿な私にアドバイスよろしくお願いしますm(_ _)m

回答No.6

30246kiku · ベストアンサー

＃４です

★ 部分を追加/変更しています。
どうでしょうか
不都合あれば修正してください

Const CREADCOL As String = "A"　　 ' 値参照列
Const CWRITEPOS As String = "B5"　　' 書き出し位置
Const CWRITECOLCNT As Long = 5　　 ' 書き出し列数
Const CSEP As String = vbLf　　　　' セル内改行文字 ' ★
Dim iReadRow As Long　　' 値参照行
Dim iWriteRow As Long ' CWRITEPOS からの書き出し相対行（ 初期値 0 ）

Private Sub ReCode(iNst As Long)
　　Dim i As Long
　　Dim v As Variant ' ★

　　If (iNst >= CWRITECOLCNT) Then
　　　　iWriteRow = iWriteRow + 1
　　　　Exit Sub
　　End If
　　For i = 1 To 2
　　　　With Range(CWRITEPOS).Offset(iWriteRow, iNst)
　　　　　　v = Split(Cells(iReadRow, CREADCOL), CSEP) ' ★
　　　　　　If (UBound(v) >= 2 ^ (CWRITECOLCNT - iNst - 1)) Then ' ★
　　　　　　　　ReDim Preserve v(2 ^ (CWRITECOLCNT - iNst - 1) - 1) ' ★
　　　　　　End If ' ★
　　　　　　.Resize(UBound(v) + 1) = WorksheetFunction.Transpose(v) ' ★
'　　　　　　.Value = Cells(iReadRow, CREADCOL) ' ★ 旧方法：値の代入だけ
　　　　　　iReadRow = iReadRow + 1
　　　　　　.Borders(xlEdgeTop).LineStyle = xlContinuous
　　　　　　Call ReCode(iNst + 1)
　　　　End With
　　Next
End Sub

Public Sub test2()
　　Dim v As Variant

　　iReadRow = 1
　　iWriteRow = 0
　　Call ReCode(0)

　　With Range(CWRITEPOS, Range(CWRITEPOS).Offset(iWriteRow - 1, CWRITECOLCNT - 1))
　　　　.Borders(xlInsideVertical).LineStyle = xlContinuous
　　　　For Each v In Array(xlEdgeBottom, xlEdgeLeft, xlEdgeRight, xlEdgeTop)
　　　　　　With .Borders(v)
　　　　　　　　.LineStyle = xlContinuous
　　　　　　　　.Weight = xlThick
　　　　　　End With
　　　　Next
'　　　　.EntireColumn.AutoFit
　　End With
End Sub

お礼

不具合なくできましたm(_ _)m
ありがとうございました。

回答No.5

web2525

欲しいものは競走馬の血統データですか？

それならネット上のデータ
http://db.netkeiba.com/horse/ped/2011102693/

↑
から直接取り込んだほうが早そうですが

補足

回答ありがとうございます。
直接取り込むというのはwebクエリのことでしょうか。
webクエリだと、1度に数10ページを取り込む時にExcelに制御され他の作業(他のブラウザで文字を打ったり)が出来なくなる場合があるので、IE制御で取り込めるようにしたいのですm(_ _)m

回答No.4

30246kiku

＃１です

間違いがあったので

> Public Sub test1()
> 　　Dim i As Long
> '　　Dim v As Variant
>
> 　　iReadRow = 1
> 　　iWriteRow = 0
> 　　For i = 1 To 2
> 　　　　Call ReCode(0)
> 　　Next

部分は、

Public Sub test1()
'　　Dim v As Variant

　　iReadRow = 1
　　iWriteRow = 0
　　Call ReCode(0)

でした。

補足

素晴らしい回答ありがとうございます。見事にできました。
ただ最初の条件と違い申し訳ないのですが、本題の方はA列が1行だけではなく、改行されておりセル内に数行あるのですが、それにも対応することはできますでしょうかm(_ _)m例えば、画像の場合だとセルA1内に4行あり、B5からB8に分けて挿入されます。B列の抜き値は最大でも16行、C列は8行、D列は4行、E列は2行、F列は1行という法則です。改行の分け方は以下のような感じでわけるというところまでわかったのですが、組み込み形がちんぷんかんぷんでした・・・
tmp = Split(指定セル, vbCrLf)
For r = 1 To UBound(tmp)
Cells(r+5, i) = tmp(r)
Next
http://www.poverty.jeez.jp/ura/img/kenmou01001.png

回答No.3

web2525

No2続き

トーナメント表のような部分の作成です
右図の規則性は、添付図を見て分かるように一覧に番号を振ると
5の倍数、10の倍数+4、20の倍数+3、40の倍数+2、80の倍数+1
の部分にデータが入ることになります（黄色に塗られたセル）

スタートの1のセルを選択した状態で

Sub Macro2()
Range(Selection.Address, Selection.Offset(31, 4).Address).Select
i = 1
No = 1
For Each R In Selection
If i Mod 80 = 1 Or i Mod 40 = 2 Or i Mod 20 = 3 Or i Mod 10 = 4 Or i Mod 5 = 0 Then
R.Value = No
No = No + 1
End If
i = i + 1
Next R
End Sub

↑
を実行すると、質問の図の右側が作られます

No2回答のマクロと組み合わせると
貼り付けたいデータがA1セルから始まっていると仮定して
貼り付けたい先頭セルを選択した状態で

Sub Macro4()

i = 1
No = 1
For Each R In Range(Selection.Address, Selection.Offset(31, 4).Address)
If i Mod 80 = 1 Or i Mod 40 = 2 Or i Mod 20 = 3 Or i Mod 10 = 4 Or i Mod 5 = 0 Then
R.Value = Range("A" & No).Value
No = No + 1
End If
i = i + 1
Next R

End Sub

回答No.2

web2525

右側のトーナメント表のような部分に数字が入っている場合は

右表1～62までを選択した状態で

Sub Macro1()
For Each R In Selection
If R.Value <> "" Then
R.Value = Range("A" & R.Value).Value
End If
Next R
End Sub

を実行すればいい

右表自体の作製も必要ならば、作成ルーチンを考える必要はありますが

回答No.1

30246kiku

以下は Excel 2007 でやってみたものですが、どうでしょうか
（コメント部分を有効にすると、罫線が引かれると思います）

test1 を実行します（効率が良いのかは分かりません）

Const CREADCOL As String = "A"　　 ' 値参照列
Const CWRITEPOS As String = "B5"　　' 書き出し位置
Const CWRITECOLCNT As Long = 5　　 ' 書き出し列数
Dim iReadRow As Long　　' 値参照行
Dim iWriteRow As Long ' CWRITEPOS からの書き出し相対行（ 初期値 0 ）

Private Sub ReCode(iNst As Long)
　　Dim i As Long

　　If (iNst >= CWRITECOLCNT) Then
　　　　iWriteRow = iWriteRow + 1
　　　　Exit Sub
　　End If
　　For i = 1 To 2
　　　　With Range(CWRITEPOS).Offset(iWriteRow, iNst)
　　　　　　.Value = Cells(iReadRow, CREADCOL)
　　　　　　iReadRow = iReadRow + 1
'　　　　　　.Borders(xlEdgeTop).LineStyle = xlContinuous
　　　　　　Call ReCode(iNst + 1)
　　　　End With
　　Next
End Sub

Public Sub test1()
　　Dim i As Long
'　　Dim v As Variant

　　iReadRow = 1
　　iWriteRow = 0
　　For i = 1 To 2
　　　　Call ReCode(0)
　　Next

'　　With Range(CWRITEPOS, Range(CWRITEPOS).Offset(iWriteRow - 1, CWRITECOLCNT - 1))
'　　　　.Borders(xlInsideVertical).LineStyle = xlContinuous
'　　　　For Each v In Array(xlEdgeBottom, xlEdgeLeft, xlEdgeRight, xlEdgeTop)
'　　　　　　With .Borders(v)
'　　　　　　　　.LineStyle = xlContinuous
'　　　　　　　　.Weight = xlThick
'　　　　　　End With
'　　　　Next
''　　　　.EntireColumn.AutoFit
'　　End With
End Sub