| |
▼Ib(初心者) さん：
シートの状態など見えないところはありますが。
マクロブックのデータ入力場所シートをコピーした新規ブックにCSVファイルから転記して保存します。
データ入力場所シートへは書き込みをしていません。コピー元として参照するだけです。
データ入力場所シートの転記領域は、あらかじめ空白にしておいてください。
なお、
新規ブック名は、B4,B5,・・・と必要なだけ記入しておいてください。
また、領域は、●部分に必要なだけ記述。以下コードでは２ヶ所にしてあります。
新規ブックの保存フォルダは ★部分。以下コードではMyDocumentにしてあります。
Sub 円楕円2_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") '■新規ブック名開始セル
' オープンする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("MyDocuments") '★保存場所
For Each myA In Array("A1:R272", "A273:R543") '●ここで転記元領域を規定。いくつでもＯＫ
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
|
|
UO3
- 13/5/13(月) 21:12 -
