人力検索はてな
モバイル版を表示しています。PC版はこちら
i-mobile

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 ネジ丸 予備品

よろしくお願いします。


●質問者: anim130M
●カテゴリ:ビジネス・経営 コンピュータ
✍キーワード:8MM Excel イメージ セル バージョン
○ 状態 :終了
└ 回答数 : 3/3件

▽最新の回答へ

1 ● SALINGER
●100ポイント

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

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

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

2 ● jccrh1
●100ポイント

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

【処理の説明】

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

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

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

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

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

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

よって改行数は複数(2つ以上)でも対応しています。

【マクロ(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
◎質問者からの返答

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

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


3 ● Mook
●500ポイント ベストアンサー

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


【在庫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 / 予備品

/ は改行

というようにデータが4列(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

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

◎質問者からの返答

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

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

関連質問


●質問をもっと探す●



0.人力検索はてなトップ
8.このページを友達に紹介
9.このページの先頭へ
対応機種一覧
お問い合わせ
ヘルプ/お知らせ
ログイン
無料ユーザー登録
はてなトップ