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

Excelのマクロに関する質問です。良い回答は、450ポイント差し上げます。
フォルダー内にあるエクセルのすべてのファイルから集計用ブックの各シートに順に貼り付ける。

※フォルダ内の【Aブック】には命名規則があり、各都道府県の名前がつけられています。
※【Bブック】シートにある製品名のみ、【Aブック】から値を取得したい。
※【Aブック】の製品名は半角カタカナ/全角カタカナが混在してます。

【Aブック】(sheet1)
例:北海道ブック
3 製品名 付属品 数量
4 テレビ スイッチ 3
5 ビデオ リモコン -5

【Bブック】(テレビシート)
3 都道府県 機器名 付属品 数量
4 北海道 テレビ スイッチ 3
5 広島 テレビ リモコン 5

【Bブック】(ビデオシート)
3 都道府県 機器名 付属品 数量
4 北海道 ビデオ リモコン -5
5 秋田 ビデオ リモコン 2

マクロでの回答は、ソースも記述願います。
どうか宜しくお願いします。


●質問者: anim130M
●カテゴリ:ビジネス・経営 コンピュータ
✍キーワード:Excel エクセル カタカナ スイッチ ソース
○ 状態 :終了
└ 回答数 : 3/3件

▽最新の回答へ

1 ● きゃづみぃ
●0ポイント

以下のソースを置く場所は 標準モジュールでも シートのところでもいいです。

Sub コピー作業()
'対象フォルダを指定してください。
'このフォルダに この集計用のブックは 入れないでください。
p = "C:\test\"

f = Dir(p & "*.xls", vbNormal)

Do While f <> ""
 Set w = Workbooks.Open(Filename:=p & f, UpdateLinks:=False, ReadOnly:=True)
 
  'ブック名になんとかブックとあったら そのブックは 除く
  'それ以外は そのまま県名とする
 If Right(f, Len("ブック.xls")) = "ブック.xls" Then
 kenmei = Left(f, Len(f) - Len("ブック.xls"))
 Else
 kenmei = Left(f, Len(f) - Len(".xls"))
 End If
 
 For a = 4 To 65536
  '製品名を取り出す
 seihin = w.Sheets("Sheet1").Cells(a, 1)
 If seihin = "" Then Exit For
 
  'その製品名のシートを作成する
  'ただし既にシートが作られていたら 作らない
 flg = True
 For Each myWS In ThisWorkbook.Worksheets
 If myWS.Name = seihin Then
 flg = False
 Exit For
 End If
 Next

 If flg Then
 ThisWorkbook.Sheets.Add.Name = seihin
 ThisWorkbook.Sheets(seihin).Cells(3, 1) = "都道府県"
 ThisWorkbook.Sheets(seihin).Cells(3, 2) = "機器名"
 ThisWorkbook.Sheets(seihin).Cells(3, 3) = "付属品"
 ThisWorkbook.Sheets(seihin).Cells(3, 4) = "数量"
 End If

  '製品のシートの一番下に追加する
 r = ThisWorkbook.Sheets(seihin).Cells(Rows.Count, 1).End(xlUp).Row + 1
 ThisWorkbook.Sheets(seihin).Cells(r, 1) = kenmei
 ThisWorkbook.Sheets(seihin).Cells(r, 2) = w.Sheets("Sheet1").Cells(a, 1)
 ThisWorkbook.Sheets(seihin).Cells(r, 3) = w.Sheets("Sheet1").Cells(a, 2)
 ThisWorkbook.Sheets(seihin).Cells(r, 4) = w.Sheets("Sheet1").Cells(a, 3)
 Next a
 w.Close
 
 
 f = Dir
Loop

End Sub
◎質問者からの返答

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

捕捉で記載してます、

【Bブック】シートにある製品名のみ、【Aブック】から値を取得したいとおもいます。


2 ● きゃづみぃ
●0ポイント

>※【Aブック】の製品名は半角カタカナ/全角カタカナが混在してます。

混在するから どうする?というのが 抜けてますので そのまま処理するようにしていましたが

とりあえず 全角に変換して 処理するように修正しました。

Sub コピー作業()
'対象フォルダを指定してください。
'このフォルダに この集計用のブックは 入れないでください。
p = "C:\test\"

f = Dir(p & "*.xls", vbNormal)

Do While f <> ""
 Set w = Workbooks.Open(Filename:=p & f, UpdateLinks:=False, ReadOnly:=True)
 
  'ブック名になんとかブックとあったら そのブックは 除く
  'それ以外は そのまま県名とする
 If Right(f, Len("ブック.xls")) = "ブック.xls" Then
 kenmei = Left(f, Len(f) - Len("ブック.xls"))
 Else
 kenmei = Left(f, Len(f) - Len(".xls"))
 End If
 
 For a = 4 To 65536
  '製品名を取り出す
 seihin = w.Sheets("Sheet1").Cells(a, 1)
 If seihin = "" Then Exit For
 seihin = StrConv(seihin , vbWide)
 
  'その製品名のシートを作成する
  'ただし既にシートが作られていたら 作らない
 flg = True
 For Each myWS In ThisWorkbook.Worksheets
 If myWS.Name = seihin Then
 flg = False
 Exit For
 End If
 Next

 If flg Then
 ThisWorkbook.Sheets.Add.Name = seihin
 ThisWorkbook.Sheets(seihin).Cells(3, 1) = "都道府県"
 ThisWorkbook.Sheets(seihin).Cells(3, 2) = "機器名"
 ThisWorkbook.Sheets(seihin).Cells(3, 3) = "付属品"
 ThisWorkbook.Sheets(seihin).Cells(3, 4) = "数量"
 End If

  '製品のシートの一番下に追加する
 r = ThisWorkbook.Sheets(seihin).Cells(Rows.Count, 1).End(xlUp).Row + 1
 ThisWorkbook.Sheets(seihin).Cells(r, 1) = kenmei
 ThisWorkbook.Sheets(seihin).Cells(r, 2) = seihin 
 ThisWorkbook.Sheets(seihin).Cells(r, 3) = w.Sheets("Sheet1").Cells(a, 2)
 ThisWorkbook.Sheets(seihin).Cells(r, 4) = w.Sheets("Sheet1").Cells(a, 3)
 Next a
 w.Close
 
 
 f = Dir
Loop

End Sub


3 ● きゃづみぃ
●450ポイント ベストアンサー

既にシートは 存在しているってことで 作成しないで その存在するシートのみ セットするようにしました。

Sub コピー作業()
'対象フォルダを指定してください。
'このフォルダに この集計用のブックは 入れないでください。
p = "C:\test\"

f = Dir(p & "*.xls", vbNormal)

Do While f <> ""
 Set w = Workbooks.Open(Filename:=p & f, UpdateLinks:=False, ReadOnly:=True)
 If Right(f, Len("ブック.xls")) = "ブック.xls" Then
 kenmei = Left(f, Len(f) - Len("ブック.xls"))
 Else
 kenmei = Left(f, Len(f) - Len(".xls"))
 End If
 
 For a = 4 To 65536
 seihin = w.Sheets("Sheet1").Cells(a, 1)
 If seihin = "" Then Exit For
 seihin = StrConv(seihin, vbWide)

 For Each myWS In ThisWorkbook.Worksheets
 If myWS.Name = seihin Then
 r = ThisWorkbook.Sheets(seihin).Cells(Rows.Count, 1).End(xlUp).Row + 1
 ThisWorkbook.Sheets(seihin).Cells(r, 1) = kenmei
 ThisWorkbook.Sheets(seihin).Cells(r, 2) = seihin
 ThisWorkbook.Sheets(seihin).Cells(r, 3) = w.Sheets("Sheet1").Cells(a, 2)
 ThisWorkbook.Sheets(seihin).Cells(r, 4) = w.Sheets("Sheet1").Cells(a, 3)
 
 Exit For
 End If
 Next

 Next a
 w.Close
 
 
 f = Dir
Loop

End Sub

◎質問者からの返答

ありがとうございます。

関連質問


●質問をもっと探す●



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