Excel VBAでファイルを１つづつ保存する方法

質問

ファイルAとファイルBと写真データが格納されているファルダAがあります。

ファイルAのNoと一致する写真データと、ファイルAのデータを１行づつ
ファイルBに転記してNo名で１つづつ保存したいです。

データは2000件ぐらいあり、手作業では困難になってしまい教えていただければ
助かります。
ご教授の程、宜しくお願いします。

【ファイルA】
------------------------------------------------------
No　都道府県　 市町村　 　　品数
11 東京都 千代田区 　　　　　50
15 埼玉県 さいたま市 30
17 神奈川県 横浜市 　　　　　60
19 京都府 京都市 　　　　　85
20 大阪府 堺市 　　　　　 99

5000 沖縄県 那覇市 　　 10
------------------------------------------------------

【ファイルB】 ファイルAから各行ごとにセルに配置して保存する
------------------------------------------------------
A1
A2(都道府県：) B2 　　　E5
A3(市町村：) B3

A6(品数：) B6
------------------------------------------------------

【フォルダA】
写真データ　ファイルAとファイルBと同じ場所にフォルダAに格納されている
------------------------------------------------------
CL0011.jpg
CL0015.jpg
CL0017.jpg
CL0019.jpg
CL0020.jpg
CL5000.jpg
------------------------------------------------------
　　↓
　　↓
　 下記が希望の結果です。
　　↓
　　↓

【11.xlsx】
------------------------------------------------------
11
都道府県： 東京都 　　　　　写真
市 町　村： 千代田区 CL0011.jpg

品　　　数： 50
------------------------------------------------------
【15.xlsx】
------------------------------------------------------
15
都道府県： 埼玉県 　　　　　写真
市 町　村： 千代田区 CL0015.jpg

品　　　数： 30
------------------------------------------------------
【17.xlsx】
------------------------------------------------------
17
都道府県： 神奈川県 　　　　　写真
市 町　村： 横浜市 CL0017.jpg

品　　　数： 30
------------------------------------------------------

宜しくお願いします。

回答No.5

kagakusuki · ベストアンサー

回答No.4の続きです。

With Application
DefaultSheetsNumber = .SheetsInNewWorkbook
.SheetsInNewWorkbook = 1
.ScreenUpdating = False
.Calculation = xlManual
.DisplayAlerts = False
End With

For i = ItemRow + 1 To LastRow
Set wb = Nothing
Set myWindow = Nothing
fn = ""
myNumber = ThisSheet.Range(NumberColumn & i).Value
If TypeName(myNumber) = "Double" And myNumber >= 0 And myNumber <= 9999 Then
myFileName = CommonString & Format(myNumber, "0000")
fn = Dir(myFolder & "\" & myFileName & ".jpg")
If fn <> "" Then

On Error Resume Next
buf = ""
buf = Windows(myNumber & ".xlsx").Caption
buf = Windows(myNumber & ".xlsx:1").Caption
If buf = "" Then
If Dir(myFolder & "\" & myNumber & ".xlsx") = "" Then
Set wb = Workbooks.Add
Else
Set wb = Workbooks.Open(myFolder & "\" & myNumber & ".xlsx")
End If
Else
Set wb = Windows(buf).Parent
Windows(buf).NewWindow
End If
On Error GoTo 0
Set myWindow = Windows(Replace(wb.Name & ":" & wb.Windows.Count, ":1", ""))

With wb.Sheets(1)
Set c = .Range(ItemColumn & .Rows.Count).End(xlUp)
If c.Value <> "" Then Set c = c.Offset(2)
If c.Row < FirstRow Then .Range (ItemColumn & FirstRow)
If .Shapes.Count > 0 Then
For Each sha In .Shapes
If sha.BottomRightCell.Row > ShapesBottom Then _
ShapesBottom = sha.BottomRightCell.Row
Next sha
If c.Top < ShapesBottom + 2 Then _
Set c = .Range(ItemColumn & ShapesBottom + 2)
End If
c.Value = myNumber
c.Offset(PrefectureRows).Value = "都道府県："
c.Offset(MunicipalityRows).Value = "市町村："
c.Offset(QuantityRows).Value = "品数："
c.Offset(PrefectureRows, 1).Value _
= ThisSheet.Range(PrefectureColumn & i).Value
c.Offset(MunicipalityRows, 1).Value _
= ThisSheet.Range(MunicipalityColumn & i).Value
c.Offset(QuantityRows, 1).Value _
= ThisSheet.Range(QuantityColumn & i).Value
Set myShape = .Shapes.AddPicture(myFolder & "\" & fn, False, True _
, c.Offset(0, PictureColumns).Left _
, c.Offset(PictureRows, 0).Top, 0, 0)
myShape.ScaleHeight 1, msoTrue
myShape.ScaleWidth 1, msoTrue
.Cells(myShape.BottomRightCell.Row + 1 _
, c.Column + PictureColumns) = fn
End With

wb.SaveAs myFolder & "\" & myNumber & ".xlsx"
myWindow.Close
Else
End If
End If
If myNumber <> "" And fn = "" Then _
ThisSheet.Range(NumberColumn & i).Interior.Color = RGB(128, 128, 128)
Next i

With Application
.SheetsInNewWorkbook = DefaultSheetsNumber
.Calculation = xlCalculationAutomatic
.DisplayAlerts = True
.ScreenUpdating = True
End With

Else
MsgBox "データの転記先のExcelBookとして設定されている" _
& vbCrLf & vbCrLf & BadWindow & vbCrLf & _
"と同名の別Book(保存先フォルダーが異なるBook)が開いているため、 " _
& "データを転記する事が出来ません。" & vbCrLf & vbCrLf _
& "このマクロによる処理を行う場合には、現在開かれている" _
& "上記のWindowのExcelBookを閉じても問題がないか否かを確認し、" _
& "特に問題がない場合には、そのWindowのExcelBookを閉じてから、" _
& "このマクロを再度起動して下さい。" _
, vbExclamation, "保存先ファイルへのアクセス不可"
End If

End Sub

回答No.4

kagakusuki

御質問文には列番号も行番号も記されていないため、ファイルAのレイアウトがどうなっているのかが不明ですので、取り敢えず仮の話として、ファイルAにおいて「No」、「都道府県」、「市町村」、「品数」等の元データが入力されているのがActivesheetであり、「No」が入力されている列がA列、「都道府県」が入力されている列がB列、「市町村」が入力されている列がC列、「品数」が入力されている列がD列であり、「11」や「東京都」といった(項目名ではない)実際のデータが入力されているのは2行目からになっているものとします。
　また、ファイルAが保存されているフォルダーと同じフォルダー内に、11.xlsx等の添付先のファイルが、もし既に存在していた場合にはその既存のファイルに転記し、もし存在していなかった場合には新規のファイルを作成してそのフォルダー内に保存するものとします。
　また、ファイルAのA列に入力されている値が「0～9999の範囲の整数値」ではない場合や、該当する「『CL』+4桁の数字+『.jpg』」のパターンに当てはまる名称のファイルが存在しなかった場合には、転記は行わず、処理を行っていない事を区別する事が出来る様にするために、そのNo.が入力されているセルを灰色で塗りつぶすものとします。
　また、もしも別の画像を同じファイル名で保存した場合において、新旧の画像が重なって見え辛くなってしまう事を防ぐために、同じ処理を繰り返した場合には、転記する位置を下にずらして転記するものとします。

　それで宜しければ、以下の様なVBAのマクロとなります。

Sub QNo9262823_Excel_VBAでファイルを1つづつ保存する方法()

Const NumberColumn As String = "A" 'Noが入力されている列の列番号
Const PrefectureColumn As String = "B" '都道府県が入力されている列の列番号
Const MunicipalityColumn As String = "C" '市町村が入力されている列の列番号
Const QuantityColumn As String = "D" '品数が入力されている列の列番号
Const ItemRow As Long = 1 '項目名が入力されている行の行番号
Const CommonString As String = "CL" '画像ファイルのファイル名に共通する文字列
Const ItemColumn As String = "A" '転記先のファイルで項目名を入力する列の列番号
Const FirstRow As Long = 1 '転記先のファイルで番号を入力する行の行番号
Const PrefectureRows As Long = 1 '転記先のファイルで都道府県を入力する行の行番号とFirstRowとの差
Const MunicipalityRows As Long = 2 '転記先のファイルで市町村を入力する行の行番号とFirstRowとの差
Const QuantityRows As Long = 5 '転記先のファイルで品数を入力する行の行番号とFirstRowとの差
Const PictureRows As Long = 4 '転記先のファイルで画像を貼り付けるセルの行番号とFirstRowとの差
Const PictureColumns As Long = 4 '転記先のファイルで画像を貼り付けるセルの列番号とItemColumnの列番号との差
Dim buf As Variant, i As Long, j As Long, wb As Workbook, c As Range _
, sha As Object, myFolder As String, fn As String, LastRow As Long _
, myNumber As Variant, ThisSheet As Worksheet, myWindow As Window _
, BadWindow As String, myShape As Shape, myFileName As String _
, ShapesBottom As Long, DefaultSheetsNumber As Integer _

LastRow = Range(NumberColumn & Rows.Count).End(xlUp).Row
If LastRow <= ItemRow Then
MsgBox "処理すべきデータが見当たりませんません。" & vbCrLf _
& "マクロを終了します。", vbExclamation, "データ無し"
Exit Sub
End If

myFolder = ThisWorkbook.Path
mySheet = ActiveSheet.Name
Set ThisSheet = ActiveSheet

For i = ItemRow + 1 To LastRow
myNumber = Range(NumberColumn & i).Value
If TypeName(myNumber) = "Double" And myNumber >= 0 And myNumber <= 9999 Then
myFileName = CommonString & Format(myNumber, "0000")
fn = Dir(myFolder & "\" & myFileName & ".jpg")
If fn <> "" Then
On Error Resume Next
buf = Windows(myNumber & ".xlsx").Caption
On Error GoTo 0
If buf = myNumber & ".xlsx" Then
If Windows(buf).Parent.Path <> myFolder Then _
BadWindow = BadWindow & buf & vbCrLf
End If
End If
End If
Next i
If BadWindow = "" Then

※　まだ途中なのですが、このサイトの回答欄には4000文字までしか入力する事が出来ない仕様となっていて、今回考えたVBAの構文の全てを1度に書き込む事が出来ませんので、残りはまた後に投稿致します。

回答No.3

Prome_Lin

何よりもまず最初に、「B.xlsx」ファイルのセル「E5」（画像を貼り付けるセル）の大きさを、画像を表示させたい大きさにして、保存しておいてください。

自動的に、セルの大きさを変えるのではなく、セルの大きさに合わせて画像を挿入しています。

まず、ファイル「A」を、「F12」で「ファイル名を付けて保存」を選択し、ファイル名が表示されている１行下の行の「∨」をクリックして、「Excel マクロ有効ブック」を選択して保存してください。

次に、その「A.xlsm」ファイルを表示したまま、「Alt＋F11」（「Alt」（「オルト」と読みます）キーを押しながら「F11」を押します）→「Visual Basic」の画面が表示されたはずなので、メニューから「挿入」→「標準モジュール」を選択すると、画面右側が白くなります。

その白くなった部分に、以下のマクロをコピー＆ペーストして「F5」で実行してください。

Sub Test()
Application.DisplayAlerts = False
p = ThisWorkbook.Path
Set t = ThisWorkbook
Set j = t.Worksheets(1)
For i = 2 To j.Range("A1").End(xlDown).Row
Set w = Workbooks.Open(p & "\B.xlsx")
Set s = w.Worksheets(1)
n = p & "\CL" & Left("00" & j.Cells(i, 1).Value, 4) & ".jpg"
s.Range("A1").Value = j.Cells(i, 1).Value
s.Range("B2").Value = j.Cells(i, 2).Value
s.Range("B3").Value = j.Cells(i, 3).Value
s.Range("E5").Select
With s.Pictures.Insert(n)
.Left = Selection.Left
.Top = Selection.Top
.Width = Selection.Width
.Height = Selection.Height
End With
w.SaveAs (p & "\" & j.Cells(i, 1).Value & ".xlsx")
w.Close
Next i
End Sub

簡単な説明です。

Application.DisplayAlerts = False

保存するときに、「保存しますか」などを聞いてこないようにしています。

p = ThisWorkbook.Path

「A.xlsm」ファイルの存在するフォルダを「p」に入れています。

Set t = ThisWorkbook

自分自身を「t」にセット。

Set j = t.Worksheets(1)

自分自身の一番左端のシートを「j」にセット。

For i = 2 To j.Range("A1").End(xlDown).Row

「A.xlsm」の２行目から、最終行までを処理。

Set w = Workbooks.Open(p & "\B.xlsx")

「B.xlsx」を開いています。

Set s = w.Worksheets(1)

「B.xlsx」の一番左端のシートを「s」にセットしています。

n = p & "\CL" & Left("00" & j.Cells(i, 1).Value, 4) & ".jpg"

「A」の「11」から実際の「jpg」のファイル名を作って「n」に入れています。

s.Range("A1").Value = j.Cells(i, 1).Value
s.Range("B2").Value = j.Cells(i, 2).Value
s.Range("B3").Value = j.Cells(i, 3).Value

それぞれ、「A」から「B」に値を代入。

s.Range("E5").Select

画像を挿入するセル「E5」を選択。

With s.Pictures.Insert(n)
.Left = Selection.Left
.Top = Selection.Top
.Width = Selection.Width
.Height = Selection.Height
End With

画像を、セルの大きさに合わせて挿入しています。

w.SaveAs (p & "\" & j.Cells(i, 1).Value & ".xlsx")

「B.xlsx」を名前を変えて保存しています。

以上です。

もし、違うところがありましたら、言ってください。

回答No.2

SI299792

いつも思うのですが、こういう質問をする方は、十分な説明をしてくれません。
足りない所をを想像で補うのですが、違っていることがよくあります。
下記のようにさせていただきます。

【ファイルA】（何行目から始まり、どの列がどのデータなのか明記してください）
１行目がタイトル、２行目以降がデータ
A:No　B:都道府県　C:市町村　D:品数
空白行は存在しない。

【写真データ】（写真データがない場合、ファイルA にない場合、どうするのか明記してください）
"CL" & No (0を入れて４桁にする) & ".jpg"
写真データがない場合ファイルを作らない。
写真データだけで、ファイルA にない場合無視する。
'
Option Explicit
'
Sub Macro1()
'
　　Dim IX As Long
　　Dim FileName As String
'
　　ChDir ThisWorkbook.Path
　　Application.ScreenUpdating = False
　　Workbooks.Open "ファイルB.xlsx"
'
　　For IX = 2 To ThisWorkbook.ActiveSheet.[A1].End(xlDown).Row
　　　　[A1] = ThisWorkbook.ActiveSheet.Cells(IX, "A")
　　　　[B2] = ThisWorkbook.ActiveSheet.Cells(IX, "B")
　　　　[B3] = ThisWorkbook.ActiveSheet.Cells(IX, "C")
　　　　[B6] = ThisWorkbook.ActiveSheet.Cells(IX, "D")
　　　　FileName = "CL" & Format([A1], "0000") & ".jpg"
'
　　　　If Dir(FileName) > "" Then
　　　　　　[C3] = FileName
　　　　　　On Error Resume Next
　　　　　　Kill [A1] & ".xlsx"
　　　　　　On Error GoTo 0
　　　　　　ActiveWorkbook.SaveAs [A1] & ".xlsx"
　　　　End If
　　Next IX
　　ActiveWindow.Close
End Sub

回答No.1

catpow

>>宜しくお願いします。

あなたがやりたいことを、細かな手順まで落とし込んで、エクセルＶＢＡのプログラムを作成すればＯＫです。
エクセルＶＢＡの本はいろいろあります。また、ネットにも沢山あります。
しっかり勉強してください。

ここは、無料のプログラミング作成依頼サイトではありませんからね。