| |
こんにちは。かみちゃん です。
>同一フォルダ内にある複数のエクセルBook（Sheet1)から値を取り出し
>転記用のエクセルBook（Sheet1)に追加転記したいのですが、初心者ためなにもわかりません。
ほぼ、同様のことをしていましたので、私のマクロを少しだけ修正してみました。
以下のコードでご希望の動作はできると思います。
ただし、元ファイルの商品名列の途中に１行でも空欄があると、そこから下は削除
しますので、注意してください。
コードの内容は、あえて、説明は書かないでおきます。
もは、わからないことがあれば、ヘルプなどでお調べいただいて、わからないとこ
ろをポイントを絞っていただいた上で再度ご質問いただければと思います。
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
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
- 05/10/28(金) 7:11 -
