| |
保存場所や変更可能だと思った場所だけ変更して実行しました。
Sub 角丸四角形3_Click()
Dim strFileName As String
Dim セル内容, パス名 As String
Dim shT As Worksheet
Dim shF As Worksheet
Dim myA As Variant
Dim myR As Range
Dim x As Long
Dim NameC As Range
Application.ScreenUpdating = False
Set NameC = Range("B4,B300,B600,B900,B1200,B1500") '■新規ブック名開始セル
' オープンするCSVファイルのフォルダを C:\ として
' ファイルオープンのダイアログを開く
ChDir ("C:\")
strFileName = Application.GetOpenFilename("CSVファイル (*.CSV),*.CSV", 1, "ファイルを選択")
If strFileName = "False" Then Exit Sub 'キャンセルボタンなら終了
'Csvファイルのシートを規定
Set shF = Workbooks.Open(Filename:=strFileName).Sheets(1)
ThisWorkbook.Sheets("データ入力場所").Copy 'このシートをコピーして新規ブックを生成
Set shT = ActiveWorkbook.Sheets(1) '新規ブックのシートを規定
パス名 = CreateObject("WSCript.Shell").SpecialFolders("C:\") '★保存場所
For Each myA In Array("A2:R272", "A273:R543", "A544:R815", "A816:R1085", "A1086:R1356", "A1357:R1627") '●ここで転記元領域を規定。いくつでもＯＫ
Set myR = shF.Range(myA)
セル内容 = NameC.Value
myR.Copy shT.Range("A3")
Application.DisplayAlerts = False '同名ブックがあれば無条件上書き
shT.Parent.SaveAs Filename:=パス名 & "\" & セル内容 & ".xlsm", FileFormat:=xlOpenXMLWorkbookMacroEnabled
Application.DisplayAlerts = True
shT.Range("A3").Resize(myR.Rows.Count, myR.Columns.Count).ClearContents
Set NameC = NameC.Offset(1)
Next
shF.Parent.Close False 'CSVファイルを閉じる
shT.Parent.Close False '作成した新規ブックを閉じる
Application.ScreenUpdating = True
MsgBox "処理終了"
End Sub
保存場所をMyDocumentsにしておけば実行は出来ましたが、1つしか保存されておらず、
タイトルが1番目もののまま、6番目のデータが中にある状態になってしまいました。
保存場所の設定と新規ブック名の入力方法が私のほうで間違っているのかもしれません。
何卒よろしくお願いいたします。
|
|
Ib(初心者）
- 13/5/14(火) 11:14 -
