Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


8893 / 13644 ツリー ←次へ | 前へ→

【30469】別Bookのデータから一覧を作りたい 初心者ひなです 05/10/28(金) 2:28 質問[未読]
【30470】Re:別Bookのデータから一覧を作りたい かみちゃん 05/10/28(金) 7:11 回答[未読]

【30469】別Bookのデータから一覧を作りたい
質問  初心者ひなです  - 05/10/28(金) 2:28 -

引用なし
パスワード
   同一フォルダ内にある複数のエクセルBook(Sheet1)から値を取り出し
転記用のエクセルBook(Sheet1)に追加転記したいのですが、初心者ためなにもわかりません。
お手数ですが どうかご教授をお願い致します。

(元ファイル1)
A      B     C      D
1会社名  xx会社
2担当者  澤田
3     商品名   定価   価格
4  1   aaa    100    50
5  2   bbb    200    100
6  3   空欄    空欄    空欄

(元ファイル2)
A      B     C      D
1会社名  ZZ会社
2担当者  ジョージ
3     商品名   定価   価格
4  1   ccc     300    150
5  2   ddd     400    200
6  3   eee     500    250

上記のファイルから、

(転記用ファイル)
A      B     C     D     E      
1会社名   担当者  商品名   定価    価格
2xx会社   澤田    aaa     100     50
3xx会社   澤田    bbb     200     100
4ZZ会社   ジョージ  ccc     300     150
5ZZ会社   ジョージ  ddd     400     200
6ZZ会社   ジョージ  eee     500     250

というようなものを作りたいです。
よろしくお願いします。

【30470】Re:別Bookのデータから一覧を作りたい
回答  かみちゃん E-MAIL  - 05/10/28(金) 7:11 -

引用なし
パスワード
   こんにちは。かみちゃん です。

>同一フォルダ内にある複数のエクセルBook(Sheet1)から値を取り出し
>転記用のエクセルBook(Sheet1)に追加転記したいのですが、初心者ためなにもわかりません。

ほぼ、同様のことをしていましたので、私のマクロを少しだけ修正してみました。
以下のコードでご希望の動作はできると思います。
ただし、元ファイルの商品名列の途中に1行でも空欄があると、そこから下は削除
しますので、注意してください。
コードの内容は、あえて、説明は書かないでおきます。
もは、わからないことがあれば、ヘルプなどでお調べいただいて、わからないとこ
ろをポイントを絞っていただいた上で再度ご質問いただければと思います。

Sub Macro1()
 Dim MyPath As String, MyName As String
 
 Range("A1:E1").Value = Array("会社名", "担当者", "商品名", "定価", "価格")
 MyPath = ThisWorkbook.Path
 MyName = Dir(MyPath & "\*.xls")
 Do While MyName <> ""
  If MyName <> ThisWorkbook.Name Then
   Workbooks.Open MyPath & "\" & MyName
   Columns("A:B").Insert Shift:=xlToRight
   Range("A4", Range("D65536").End(xlUp).Offset(, -2)) = Array(Range("D1"), Range("D2"))
   Columns("C:C").Delete Shift:=xlToLeft
   Rows("1:3").Delete Shift:=xlUp
   Rows(Range("C65536").End(xlUp).Row + 1 & ":65536").Delete Shift:=xlUp
   Range("A1").CurrentRegion.Copy
   ThisWorkbook.Activate
   Range("A65536").End(xlUp).Offset(1).Select
   ActiveSheet.Paste
   Workbooks(MyName).Activate
   ActiveWorkbook.Saved = True
   ActiveWorkbook.Close
  End If
  MyName = Dir
 Loop
End Sub

8893 / 13644 ツリー ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free