重要なお知らせ

「教えて! goo」は2025年9月17日(水)をもちまして、サービスを終了いたします。詳細はこちら>

【GOLF me!】初月無料お試し

以下のような一セル内で改行された文字列を改行ごとに分割して別シートへコピーするExcelVBAを作成したいと考えています。
(以下は山田さんのレコード一行を記載しましたが下のセルに担当者のレコードが同様に続きます。)

   A         B           C          D
 ----------+---------------+------------+---------------+ 
 担当者      日付         履歴        更新日
 ----------+---------------+------------+---------------+
 山田       2001/01/01    札幌支店    2005/01/01
           2002/01/01    福岡支店    2005/04/01
           2003/04/01    東京支店    2005/04/01
 ----------+---------------+------------+---------------+

上記を別シートへ以下のようにセル内容を分割してコピーしたいのです。
   A         B            C           D
 ----------+---------------+------------+---------------+
  担当者     日付         履歴       更新日
 ----------+---------------+------------+---------------+
   山田     2001/01/01    札幌支店     2005/01/01
 ----------+---------------+------------+---------------+
   山田     2002/01/01    福岡支店     2005/04/01
 ----------+---------------+------------+---------------+
   山田     2003/04/01    東京支店     2005/04/01
 ----------+---------------+------------+---------------+

※質問の表記で-------------+-----------と記載しているのは
セルをイメージしました。A1に「担当者」A2に「山田」と記載しているイメージです。問題はB.C.D列のセル内容ですが前任者が一つのセルに改行を利用して入力しているため、内容を行に分割したいと考えています。件数が非常に多く手作業を排除した方法でVBAを利用した方法がわかる方にお教えいただきたく投稿させていただきました。
当方Excel2000を利用していますが上記の処理VBAマクロをどうか教えてください。

A 回答 (4件)

Sheet2には最低限項目名が記入されていると仮定しています


下記のような感じでしょう
Sub Macro1()
  Dim r1 As Range, r2 As Range, s As String
  Dim ar() As String, n As Integer, m As Integer, i As Integer
  ' Sheet1のA2セルから開始
  Set r1 = Sheet1.Range("A2")
  ' Sheet2のA列の最後+1行目から開始
  Set r2 = Sheet2.Range("A65536").End(xlUp).Offset(1)
  ' Sheet1のデータが無くなるまでループ
  Do While r1.Value <> ""
    ' セル内改行の最大数を記憶するための変数iを初期化
    i = 0
    For m = 1 To 3
      ' Sheet1の B,C,D列のデータをLFで分割
      ar = Split(r1.Offset(0, m).Value, vbLf)
      For n = 0 To UBound(ar)
        ' Sheet2へ転記
        r2.Offset(n, m).Value = ar(n)
      Next
      ' 分割数の最大値を判断
      If UBound(ar) + 1 > i Then i = UBound(ar) + 1
    Next
    s = r0.Value
    ' Sheet2のA列に転記
    r2.Resize(i, 1).Value = s
    ' Sheet1を次行に移動
    Set r1 = r1.Offset(1)
    ' Sheet2を転記した次の行に移動
    Set r2 = r2.Offset(i)
  Loop
End Sub
    • good
    • 0
この回答へのお礼

お教えいただいた方法で意図する作業がうまくいきました。どうもありがとうございます。

お礼日時:2008/01/14 13:12

ANo.3です。


ミスしてました。

>ReDim Preserve v(1 To 4, 1 To i - 1)

ReDim Preserve v(1 To 4, 1 To i)
に変更願います。
    • good
    • 0
この回答へのお礼

お教えいただいた方法を参考にさせていただきます。どうもありがとうございました。

お礼日時:2008/01/14 13:13

シート1からシート2へ書き出すサンプル。



Sub try()
 Dim r As Range
 Dim v, vv1, vv2, vv3
 Dim i As Long, k As Integer

 With Worksheets("Sheet1")
      ReDim v(1 To 4, 1 To .Cells.Rows.Count)

      For Each r In .Range(.[A2], .Cells(Rows.Count, 1).End(xlUp))
          vv1 = Split(r.Offset(, 1).Value, vbLf)
          vv2 = Split(r.Offset(, 2).Value, vbLf)
          vv3 = Split(r.Offset(, 3).Value, vbLf)
          
          For k = 0 To UBound(vv1)
              i = i + 1
              v(1, i) = r.Value
              v(2, i) = vv1(k)
              v(3, i) = vv2(k)
              v(4, i) = vv3(k)
          Next
      Next
      ReDim Preserve v(1 To 4, 1 To i - 1)
 End With
 With Worksheets("Sheet2")
      .Range("A1:D1").Value = Array("担当者", "日付", "履歴", "更新日")
      .Range("A2").Resize(UBound(v, 2), 4).Value = Application.Transpose(v)
 End With
 Erase v
End Sub
ご参考になれば。
    • good
    • 0

Sub test()


strTest = Cells(1, 1).Value
Cells(1, 2) = InStr(1, strTest, vbLf)
End Sub

でセル内の改行位置を判定できます。
セル内のvbLfを探せば文字を分割する位置が判断できます。
    • good
    • 0
この回答へのお礼

判定条件を理解しました。ありがとうございました。

お礼日時:2008/01/14 13:11

お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!

今、見られている記事はコレ!