id:anim130M
ポイントあり700ptベストアンサーあり
ビジネス・経営コンピュータ

Excelのマクロに関する質問です。良い回答は、500ポイント差し上げます。

ファイルに複数のシートがあり、ある行に記載されている文字列(部品名)から、下記部分に記載されている値を取得し、新規ファイルにまとめてリスト化したい。
このとき、用途セルの文字列が改行されている際は、集計シートでは行を追加して記載したい。
Excelのバージョンは2003です。
【在庫Aシート】
2　部品名
3　No サブNO 部品名 用途
4　5 　 A ネジ平 1.5mm　←改行
　　　　　　　　　　　特注品　
5　9 　 ネジ丸 1.8mm
【在庫Bシート】
2　部品名　
3　No サブNO 部品名 用途
4　2 　 C ネジ平 1.5mm
5　1 　 A ネジ丸 1.8mm　←改行
　　　　　　　　　　　予備品

【集計ファイル（出力イメージ）】
1 5 A ネジ平 1.5mm
2 5 A ネジ平 特注品　
3 9 ネジ丸 1.8mm
4 2 C ネジ平 1.5mm
5 1 A ネジ丸 1.8mm
6 1 A ネジ丸 予備品

よろしくお願いします。

回答の条件
  • 1人2回まで
  • 登録：
  • 終了：2009/04/17 22:01:38
※ 有料アンケート・ポイント付き質問機能は2023年2月28日に終了しました。

ベストアンサー

id:Mook No.3

回答回数1314ベストアンサー獲得回数393

ポイント500pt

少しデータの様子がわからないのですが、


【在庫Aシート】

2 部品名
3 No サブNO 部品名 用途
4 5 A ネジ平 1.5mm / 特注品
5 9 ネジ丸 1.8mm

【在庫Bシート】

2 部品名
3 No サブNO 部品名 用途
4 2 C ネジ平 1.5mm
5 1 A ネジ丸 1.8mm / 予備品

　　※ / は改行

というようにデータが４列（A～D列）あって、D列が複数行ある場合

A～C列を同じ値で、改行ごとにデータを転記するという仕様でよい

のでしょうか。


上記の内容での処理例です。

'-----------------------------------------------------
' 全体の処理
'-----------------------------------------------------
Sub makeItemList()
'-----------------------------------------------------
    Dim ws As Worksheet
    
    Dim wb As Workbook
    Set wb = Workbooks.Add()
    
    Dim dstWS As Worksheet
    Set dstWS = wb.Worksheets(1)
    
    Dim dstRow As Long
    Dim srcWS As Worksheet
    For Each srcWS In ThisWorkbook.Worksheets
        makeListFromWS dstWS, srcWS, dstRow
    Next
End Sub

'-----------------------------------------------------
' 1 シート分の処理
'-----------------------------------------------------
Sub makeListFromWS(dstWS As Worksheet, srcWS As Worksheet, dstRow As Long)
'-----------------------------------------------------
    Dim startRow As Long
    Dim fr As Range
    Set fr = srcWS.Columns("A").Find(what:="部品名", lookat:=xlWhole)
    If fr Is Nothing Then Exit Sub

    startRow = fr.Row + 2
    
    Dim lastRow As Long
    lastRow = srcWS.Cells(Rows.Count, "A").End(xlUp).Row
    
    Dim r As Long
    Dim i As Long
    Dim wArray As Variant
    
    For r = startRow To lastRow
        If srcWS.Cells(r, "A").Value <> "" Then
            wArray = Split(srcWS.Cells(r, "D").Value, vbLf)
            For i = LBound(wArray) To UBound(wArray)
                dstRow = dstRow + 1
                srcWS.Cells(r, "A").Resize(1, 3).Copy Destination:=dstWS.Cells(dstRow, "A").Resize(1, 3)
                dstWS.Cells(dstRow, "D") = wArray(i)
            Next
        End If
    Next
End Sub

不明な点や、仕様の誤解はコメントにて対応いたします。

id:anim130M

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

理想通りです、ありがとうございました。

2009/04/17 22:00:20

その他の回答（2件）

id:SALINGER No.1

回答回数3454ベストアンサー獲得回数969

ポイント100pt

こんな感じでどうでしょうか。

実行すると、新たに集計ファイルというシートを追加して全てのシートを集計します。

Option Explicit

Sub Macro()
    Dim syuukei As Worksheet
    Dim ws As Worksheet
    Dim i As Long
    Dim j As Long
    Dim k As Long
    Dim lastRow As Long
    Dim tmp As Variant
    
    Set syuukei = Worksheets.Add
    syuukei.Name = "集計ファイル"
    
    i = 1
    For Each ws In ThisWorkbook.Worksheets
        If ws.Name <> "集計ファイル" Then
            lastRow = ws.Cells(Rows.Count, 1).End(xlUp).Row
            
            For j = 4 To lastRow
                tmp = Split(ws.Cells(j, "D").Value, Chr(10))
                For k = 0 To UBound(tmp)
                    syuukei.Cells(i, 1).Value = ws.Cells(j, 1).Value
                    syuukei.Cells(i, 2).Value = ws.Cells(j, 2).Value
                    syuukei.Cells(i, 3).Value = ws.Cells(j, 3).Value
                    syuukei.Cells(i, 4).Value = tmp(k)
                    i = i + 1
                Next k
            Next
        End If
    Next
End Sub
id:jccrh1 No.2

回答回数111ベストアンサー獲得回数19

ポイント100pt

前回の回答に一部変更を加えました。

　

【処理の説明】

・在庫のブックを開きます（複数ブック可）。

・集計用ブックを新規に作成し、下記のマクロを入力します。

　集計マクロを実行すれば、リスト化します。

※抽出するデータはC列にデータが入っていて「部品名」ではないデータを対象としました。

※変数の宣言は省略しました。

☆今回は用途を改行コードで分割しました。

　よって改行数は複数（２つ以上）でも対応しています。

　

【マクロ(VBA)】

Sub 集計()
  Set 集計セル = ThisWorkbook.ActiveSheet.Cells
  集計セル.ClearContents
  For ブックNO = 1 To Workbooks.Count
    If Workbooks(ブックNO).Name <> ThisWorkbook.Name Then
      Workbooks(ブックNO).Activate
      For シートNO = 1 To Worksheets.Count
        Worksheets(シートNO).Activate
        Set 検索範囲 = Range("A1", Cells.SpecialCells(xlCellTypeLastCell))
        For 行NO = 1 To 検索範囲.Rows.Count
          If Trim(検索範囲(行NO, 3)) <> "" And Trim(検索範囲(行NO, 3)) <> "部品名" Then
            行分割 = Split(検索範囲(行NO, 4), vbLf)
            For 分割数 = 0 To UBound(行分割)
              集計行 = 集計行 + 1
              集計セル(集計行, 1) = 検索範囲(行NO, 1)
              集計セル(集計行, 2) = 検索範囲(行NO, 2)
              集計セル(集計行, 3) = 検索範囲(行NO, 3)
              集計セル(集計行, 4) = 行分割(分割数)
            Next 分割数
          End If
        Next 行NO
      Next シートNO
    End If
  Next ブックNO
End Sub
id:anim130M

たびたびありがとうございます。

ご回答いただきましてありがとうございます。

2009/04/17 21:58:11
id:Mook No.3

回答回数1314ベストアンサー獲得回数393ここでベストアンサー

ポイント500pt

少しデータの様子がわからないのですが、


【在庫Aシート】

2 部品名
3 No サブNO 部品名 用途
4 5 A ネジ平 1.5mm / 特注品
5 9 ネジ丸 1.8mm

【在庫Bシート】

2 部品名
3 No サブNO 部品名 用途
4 2 C ネジ平 1.5mm
5 1 A ネジ丸 1.8mm / 予備品

　　※ / は改行

というようにデータが４列（A～D列）あって、D列が複数行ある場合

A～C列を同じ値で、改行ごとにデータを転記するという仕様でよい

のでしょうか。


上記の内容での処理例です。

'-----------------------------------------------------
' 全体の処理
'-----------------------------------------------------
Sub makeItemList()
'-----------------------------------------------------
    Dim ws As Worksheet
    
    Dim wb As Workbook
    Set wb = Workbooks.Add()
    
    Dim dstWS As Worksheet
    Set dstWS = wb.Worksheets(1)
    
    Dim dstRow As Long
    Dim srcWS As Worksheet
    For Each srcWS In ThisWorkbook.Worksheets
        makeListFromWS dstWS, srcWS, dstRow
    Next
End Sub

'-----------------------------------------------------
' 1 シート分の処理
'-----------------------------------------------------
Sub makeListFromWS(dstWS As Worksheet, srcWS As Worksheet, dstRow As Long)
'-----------------------------------------------------
    Dim startRow As Long
    Dim fr As Range
    Set fr = srcWS.Columns("A").Find(what:="部品名", lookat:=xlWhole)
    If fr Is Nothing Then Exit Sub

    startRow = fr.Row + 2
    
    Dim lastRow As Long
    lastRow = srcWS.Cells(Rows.Count, "A").End(xlUp).Row
    
    Dim r As Long
    Dim i As Long
    Dim wArray As Variant
    
    For r = startRow To lastRow
        If srcWS.Cells(r, "A").Value <> "" Then
            wArray = Split(srcWS.Cells(r, "D").Value, vbLf)
            For i = LBound(wArray) To UBound(wArray)
                dstRow = dstRow + 1
                srcWS.Cells(r, "A").Resize(1, 3).Copy Destination:=dstWS.Cells(dstRow, "A").Resize(1, 3)
                dstWS.Cells(dstRow, "D") = wArray(i)
            Next
        End If
    Next
End Sub

不明な点や、仕様の誤解はコメントにて対応いたします。

id:anim130M

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

理想通りです、ありがとうございました。

2009/04/17 22:00:20

コメント（0件)

コメントはまだありません

この質問への反応（ブックマークコメント）

「あの人に答えてほしい」「この質問はあの人が答えられそう」というときに、回答リクエストを送ってみてましょう。

これ以上回答リクエストを送信することはできません。制限について

回答リクエストを送信したユーザーはいません
ユーザー登録をして使いはじめる!無料
すでに登録されている方はこちらからログイン
この質問に含まれるキーワード
知りたいことを検索してみよう
▲ページトップへ