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

ファイルに複数のシートがあり、ある行に記載されている文字列(部品名)から、下記部分に記載されている・文字列・数値(No、サブNO、部品名、用途)を取得し、新規ファイルにまとめてリスト化したい。
このとき、在庫各シートの文字列(部品名)は固定された列に記載されていますが、行は変動です。
【在庫Aシート】  
1 ○□

3 部品名
4
5 No サブNO 部品名 用途  ××
6 5  A ネジ平 1.5mm  ・
7 9  A ネジ丸 1.8mm  ・
8 . . . .
10 ○□ ←この部分は要らない
11 部品名
12
13 No サブNO 部品名 用途  ××
14     B ネジ平 1.5mm  ・
15 6   C ネジ丸 1.8mm  ・

【在庫Bシート】  
1 ○□
2 部品名
3
4 No サブNO 部品名 用途  ××
5 1 A ネジ平 1.5mm  ・

【集計ファイル(出力イメージ)】
1 5 A ネジ平 1.5mm
2 9 A ネジ丸 1.8mm
3  B ネジ平 1.5mm
4 6 C ネジ丸 1.8mm
5 1 A ネジ平 1.5mm

よろしくお願いします

回答の条件
  • 1人2回まで
  • 登録:2009/04/09 22:35:34
  • 終了:2009/04/10 01:19:53

ベストアンサー

id:jccrh1 No.2

jccrh1回答回数111ベストアンサー獲得回数192009/04/10 00:06:07

ポイント700pt

【処理の説明】

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

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

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

※抽出するデータは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

      集計行 = 集計行 + 1

      集計セル(集計行, 1) = 検索範囲(行NO, 1)

      集計セル(集計行, 2) = 検索範囲(行NO, 2)

      集計セル(集計行, 3) = 検索範囲(行NO, 3)

      集計セル(集計行, 4) = 検索範囲(行NO, 4)

     End If

    Next 行NO

   Next シートNO

  End If

 Next ブックNO

End Sub

id:anim130M

ありがとうございました。

望み通りに動きました。

2009/04/10 01:17:59

その他の回答(2件)

id:kn1967 No.1

kn1967回答回数2915ベストアンサー獲得回数3012009/04/09 23:23:16

ポイント10pt

コメント欄が開いていないので本回答で失礼。


○□

には何か入っているということ?

それとも逆に何も入っていないということ?


データの開始点は「No サブNO 部品名 用途  ××」の

次の行からと認識できるのだけれども各部品に必要なパーツの終点となっている行を

求めるために、この情報は必須かと・・・。


それとExcelのバージョンも書いておいたほうがよろしいかと思います。

(Excel95/97って事は無いと思いますが

Excel2000あたりはバリバリ現役だったりしますから・・・)


これから寝るので回答には間に合わないと思いますが

以上、気になりましたので、ご確認くださいませ。

※コメント欄空けておくと、こういった程度のことでポイント使わなくて済みますし

他の方も即時確認できるのでよろしいかと思います。

id:anim130M

説明不足な文面となってしまい申し訳ございませんでした。

今後の気をつけたいと思います。ありがとうございました。

2009/04/10 01:17:02
id:jccrh1 No.2

jccrh1回答回数111ベストアンサー獲得回数192009/04/10 00:06:07ここでベストアンサー

ポイント700pt

【処理の説明】

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

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

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

※抽出するデータは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

      集計行 = 集計行 + 1

      集計セル(集計行, 1) = 検索範囲(行NO, 1)

      集計セル(集計行, 2) = 検索範囲(行NO, 2)

      集計セル(集計行, 3) = 検索範囲(行NO, 3)

      集計セル(集計行, 4) = 検索範囲(行NO, 4)

     End If

    Next 行NO

   Next シートNO

  End If

 Next ブックNO

End Sub

id:anim130M

ありがとうございました。

望み通りに動きました。

2009/04/10 01:17:59
id:Mook No.3

Mook回答回数1312ベストアンサー獲得回数3912009/04/10 00:55:39

ポイント10pt

検索対象を現在のブック内のすべてのシート、出力は新規に作成するという仕様での例です。


検索を行うファイルの標準モジュールに下記を貼り、実行してみてください。

不明な点、仕様の変更はコメントに手対応いたしますので、有効にお願いいたします。

'---------------------------------------------
Sub makeList()
'---------------------------------------------
    
'---------------------------------------------
' リスト出力ファイルを新規に作成
'---------------------------------------------
    Dim listWB As Workbook
    Set listWB = Workbooks.Add()
    
    Dim listWS As Worksheet
    Set listWS = listWB.Worksheets(1)
    
    Dim ws As Worksheet
    Dim listRow As Long
    Dim lastRow As Long
    Dim i As Long
'---------------------------------------------
' 現在のブックのすべてのシートを検索
'---------------------------------------------
    For Each ws In ThisWorkbook.Worksheets
        With ws
'---------------------------------------------
' C列を見て、最終行を判断
'---------------------------------------------
        lastRow = .Range("C" & Rows.Count).End(xlUp).Row
        For i = 1 To lastRow
'---------------------------------------------
' リストするデータは下記の条件をすべて満たす場合
'   A列が 「No」ではない
'   A列が 「部品名」ではない
'   C列が 空白ではない
'---------------------------------------------
            If Len(Trim(.Cells(i, "C"))) > 0 _
                And InStr(.Cells(i, "A"), "No") = 0 _
                And InStr(.Cells(i, "A"), "部品名") = 0 Then
                listRow = listRow + 1
                .Range("A" & i).Resize(1, 4).Copy Destination:=listWS.Range("A" & listRow).Resize(1, 4)
            End If
        Next
        End With
    Next
End Sub

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

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

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

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

絞り込み :
はてなココの「ともだち」を表示します。
回答リクエストを送信したユーザーはいません