VBA データ取得について

Question

前提・実現したいこと

ExcelのVBAでシート１の縦に並んだデータをコピーペーストしてシート2に横に並べていくプログラムを作りたいです。１つのセルに１つの値が入っています。

例)シート１ →　シート2
１ 1 あ 3 4 JPN〇〇〇
あ 4 6 いいい JPN〇〇〇
３ …
４
JPN○○○
４
6
いいい
JPN〇〇〇
…

上記のようなシート１の値を１行ずつ取得し、シート２に横に並べ、特定のアルファベットJPNがきたら改行しまた処理をする繰り返し処理のプログラム作成を考えています。

試したこと

xlDownで縦のデータを全てコピーしてPasteSpecial Transpose:=Trueで横にデータをペーストすることはできたのですが、アルファベットがきたら改行し、処理を繰り返したり、１行ずつコピーペーストするプログラムの書き方が分かりません・・・。
if文などでlike*"A"*のような文を応用すればできそうな気がしているのですが、理解力が足りず詰まってしまっています・・・。
似たようなプログラムを組んだことのある方がいればアドバイスを頂きたいです。

Comments

[tatsu99]

１．１つのセルに１文字ではなく、AAAのように３文字の場合もあるのですか。
２．その場合、「３A５」のような文字があったときも、改行するのですか。
３．アルファベットは、大文字と小文字の両方が対象ですか。
４．特殊文字（＃、＆、％等）が入ることはないのですか。もし、あるなら、その場合は改行しなくでよいのですか。

[Dai5]

ご指摘ありがとうございます。

1.1つのセルには複数の文字が入っています。漢字やひらがな、カタカナ、アルファベット、数字などが使われています。

2.説明不足ですみません。
3A5の場合は改行はしません。
先頭に特定のアルファベットがついてい る時に改行したいです。ここではAとしてしまっているのでややこしいですが、実際にはJPN○○○のような商品番号？みたいなデータを扱っているので、この固定されているJPNを検知して改行という形にしたいです。

3.大文字のみです。

4.特殊文字が入ることはなく、もし入っても改行はしません。

よろしくお願いいたします。

Answer 1

Option Explicit

Sub test()
    Dim rngCopyForm As Range　　'コピー元セル範囲
    Dim rngCopyTo As Range　　　'コピー先セル範囲（左上）
    Dim c As Range　　　　　　　　'セル範囲の内の各セル
    Dim ixRow As Long　　　　　　'行番号
    Dim ixCol As Long　　　　　　'列番号
    Dim v As Variant　　　　　　　'セルの値
    
    Set rngCopyForm = Worksheets("シート1").Range("A1").CurrentRegion.Cells
    Set rngCopyTo = Worksheets("シート2").Range("A1").Cells
    ixRow = 1
    ixCol = 1
    
    For Each c In rngCopyForm
        v = c.Value
        rngCopyTo(ixRow, ixCol).Value = v
        If v Like "JPN*" Then
            ixRow = ixRow + 1
            ixCol = 1
        Else
            ixCol = ixCol + 1
        End If
    Next
End Sub

僕が書いたらこんな感じです。
他の方とほぼほぼ同じですが、違いが重要だと思いますので、
書いてみます。

こうでなければならないというわけではないですが、
後で、自分で読みやすいコードを書けるようになるといいと思います。
（コメントが要るのか要らないのか等々）
参考になれば。。。

Comments

[Dai5]

mattuwanさん
ありがとうございます！
読みやすさも意識してみようと思います。

Answer 2

こんばんは。こういうのですかね？

Sub Tenki()
'Sheet1のA列にある文字列を上から順に検査して
'Sheet2へ、A1セルを起点として、順次転記していきます
'そのとき、"JPN"という文字列がセルに含まれていたら
'次の行に改行します
'"JPN"という文字列が発見されないかぎり、Sheet2には右へ転記していきます

Dim r As Range  '転記する対象のセル（レンジ）です
Dim I As Long   'sheet2のI行目に転記します
Dim J As Long   'Sheet2のJ列目に転記します

I = 1   '何行目かをコントロールします
J = 1   '何列目かをコントロールします

'元になるSheet1をセレクトしておきます
Worksheets("sheet1").Select

'Sheet1のA列が空白になるまで繰り返すループです
For Each r In Worksheets("sheet1").Range("A1", Range("A1").End(xlDown))
        'r をSheet2のJ列目に転記します
        Worksheets("sheet2").Cells(I, J) = r.Value

        'Sheet1のA列のセルに、もし"JPN"という文字列を発見しなかったら
        If InStr(r.Value, "JPN") = 0 Then
                '右に一個ズレておきます。下にはズレません。
                J = J + 1
        Else    'もし"JPN"という文字列を発見したら
                '次の行に一個ずらします
                I = I + 1
                '次のデータのために１列目にリセットします
                J = 1
        End If
Next r
End Sub

結果はこのようになりますね。

Comments

[Dai5]

AkiSaitoさん
ありがとうございます！
実現したかったことができました。

Answer 3

こんにちは。
目的がシート１からシート２への条件付きコピーということなら、自分もAkiSaitoさんと似たようなコードを書くと思います。

コピー＆ペーストがマストなのでしょうか？

Comments

[Dai5]

DreamTheaterさん
コメントありがとうございます。
コピー＆ペーストがやりたかったので、AkiSaitoさんのを参考にさせて頂きました！