| |
昨夜、自分なりにいじってみたのですが、デバックエラーの連続で進まなかったコードも載せてみます。
あまり知識がないままいじってみてしまったので、的外れなのかもしれませんが、
これを実行してもSaveAsメソッドが失敗と出てしまいます。
先ほど載せ忘れたのですが、エラーの起きる位置は
shT.Parent.SaveAs Filename:=パス名 & "\" & セル内容 & ".xlsm", FileFormat:=xlOpenXMLWorkbookMacroEnabled
の部分です。
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(5) As String
Dim i As Integer
Application.ScreenUpdating = False
' オープンするCSVファイルのフォルダを C:\ として
' ファイルオープンのダイアログを開く
ChDir ("C:\")
strFileName = Application.GetOpenFilename("CSVファイル (*.CSV),*.CSV", 1, "ファイルを選択")
If strFileName = "False" Then Exit Sub 'キャンセルボタンなら終了
NameC(5) = Range("B4,B300,B600,B900,B1200,B1500") '■新規ブック名開始セル
'Csvファイルのシートを規定
Set shF = Workbooks.Open(Filename:=strFileName).Sheets(1)
ThisWorkbook.Sheets("データ入力場所").Copy 'このシートをコピーして新規ブックを生成
Set shT = ActiveWorkbook.Sheets(1) '新規ブックのシートを規定
パス名 = CreateObject("WSCript.Shell").SpecialFolders("MyDocuments") '★保存場所
For Each myA In Array("A2:R272", "A273:R543", "A544:R815", "A816:R1085", "A1086:R1356", "A1357:R1627") '●ここで転記元領域を規定。いくつでもＯＫ
Set myR = shF.Range(myA)
i = 0
セル内容 = NameC(i)
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
i = i + 1
Next
shF.Parent.Close False 'CSVファイルを閉じる
shT.Parent.Close False '作成した新規ブックを閉じる
Application.ScreenUpdating = True
MsgBox "処理終了"
End Sub
何度も申し訳ありません。ご親切に教えていただけて、本当に感謝しております。
何卒よろしくお願いいたします。
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
