VBA転記について教えて下さい

質問

200件位のデータがあるとします。顧客情報AB・商品C～AY

氏名　性　　青森りんご　長野りんご　みかん　バナナ　送料
AA　 男　　　1　　　　　　　　　　　　 2　　　　　　100
BB　 女　　　　　　　　　　1　　　　　　　　　　　　100
CC　 男　　　　　　　　　　　　　　　　　　 3　　　　 0

このデータを別シートAにはりんごと送料　別シートBにはそれ以外のデータに分けたいのです。

シートA
氏名　性　　青森りんご　長野りんご　　送料
AA　　男　　　1　　　　　　　　　　　100
BB　　女　　　　　　　　1　　　　100
CC　　男

シートB
氏名　性　　みかん　バナナ
AA　　男　　　 2
BB　　女
CC　　男　　　　　　 3

こんな感じです。

色々参考にして作成しましたがうまくいきませんでしたので
教えて欲しいです。
よろしくお願いします。
エクセルは2002です。

１、項目名の転記でデータは200位ですが変動があるので最終行で作成したら
うまくいきませんでした。

２、データ域の転記が動きません。

Sub サンプル()

Dim i As Long
Dim lastRow As Long
Dim lastcolumns As Long
Dim S1 As Worksheet, S2 As Worksheet, S3 As Worksheet
Dim myColumns As Long
Dim myKey As String

Set S1 = Worksheets("データ")
Set S2 = Worksheets("りんご")
Set S3 = Worksheets("その他")

' Sheet1の最終行を取得
lastRow = S1.Range("A" & Rows.Count).End(xlUp).Row

' Sheet1の最終列を取得
lastcolumns = S1.Cells(1, Columns.Count).End(xlToLeft).Column
' 項目名の転記
S2.Range("A1:B200").Value = _
S1.Range("A1:B200").Value

S3.Range("A1:B200").Value = _
S1.Range("A1:B200").Value
'データ域の転記
For i = 2 To lastcolumns
myKey = S1.Cells(1 & i).Value
If myKey <> "" Then
myColumns = Worksheets(myKey).Cells(1, Columns.Count).End(xlUp).Columns + 1
S1.Range(S1.Cells(1, i), S1.Cells(lastRow, i)).Copy _
Worksheets(myKey).Range(Cells(1, myColumns), Cells(lastRow, myColumns))
End If
Next i
End Sub

回答No.2

tsubu-yuki · ベストアンサー

直接の解決策ではないのですが、
・作業用の一時シートを作って
・そこに「行列を入れ替えて貼り付け」し
・フィルタをかけて
・転記先シートに「行列を入れ替えて貼り付け」
を記録して、贅肉を取っていったらいかがでしょう？
２００行程度ならあまり変わらないかもしれませんが、
全行・全列への繰り返し処理で悩んでいらっしゃるのであれば
こちらのほうが解りやすいような気がします。

とりあえず、以下は
エクセルを動かさないで、ご提示のコードを読んだ感想です。

> myColumns = Worksheets(myKey).Cells(1, Columns.Count).End(xlUp).Columns + 1
(xlUp)ではなく、(xlToLeft)かな。

もうひとつ、
> ' Sheet1の最終列を取得
> lastcolumns = S1.Cells(1, Columns.Count).End(xlToLeft).Column
でもここは、
> 顧客情報AB・商品C～AY
なのだから、AY列=51列目 固定なのでは？
つまり、不要。
　　'データ域の転記
　　For i = 3 To 51
で十分な気がします。
列の数が可変なのであれば、要りますね。

根本、
> myKey = S1.Cells(1 & i).Value
> If myKey <> "" Then
> myColumns = Worksheets(myKey).（略）
これだと「myKey」、
例を挙げると「青りんご というシート」に書きに行っちゃいますね。
なので、例えば
　　If S1.Cells(1 & i).Value = "青森りんご" Or _
　　　 S1.Cells(1 & i).Value = "長野りんご" Or _
　　　 S1.Cells(1 & i).Value = "送料" Then
　　　　myKey = "りんご"
　　Else
　　　　myKey = "その他"
　　End If
　　myColumns = Worksheets(myKey).Cells(1, Columns.Count).End(xlToLeft).Columns + 1
としてやれば、少しは動くかな・・という気もします。
　※ごめんなさい、未検証です。

で、たぶん、LastRowも要らない気がします。
列全体をコピー貼り付けで十分かな。

書き方がわからないところは「マクロの記録」を有効活用しましょうね。

お礼

ご回答ありがとうございます。
これから訂正してみます。

色々やってみて行き詰ったらまたよろしくお願いします。

回答No.1

imogasi

この問題は簡単じゃないか。うまくいかないとはどういう点か。
元データｓ１のi行目のデータは、Ｓ２シート、Ｓ３シートそれぞれのi 行に持って行けばよいので簡単と思う。何か問題あるか。列データもＣｏｐｙするよりも、私なら代入でシコシコやってみる。
下記は、これ以上を繰り返して書く気も出ない、平凡なコードの書き連ねだろう。
下記は荒っぽいが、あとは補充できるだろう。
ーー
Sub test01()
Set S1 = Worksheets("データ")
Set S2 = Worksheets("りんご")
Set S3 = Worksheets("その他")
lr1= S1.Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To lr1
sh2.Cells(i, "A") = sh1.Cells(i, "A")
sh2.Cells(i, "B") = sh1.Cells(i, "B")
'--データ列リンゴ代入　略
'--データ列手数料代入　略
'－－－
sh3.Cells(i, "A") = sh1.Cells(i, "A")
sh3.Cells(i, "B") = sh1.Cells(i, "B")
'--データ列その他　略
'--データ列手数料代入　略
Next i
End Sub
データ列が、４列以上あってもそれぐらい対応できるだろう。

お礼

ご回答ありがとうございます。

これから修正をしてみます。

お礼が遅れてしまい申し訳ありませんでした。

まだまだ勉強中でして、うまく行きませんでした。
色々やってみます。
ありがとうございました。