| |
▼Ib(初心者) さん：
おはようございます
改訂版です。
保存ブックが xlsm なので、このマクロブック自体をマクロ付で保存しています。
転記の後、転記領域をクリアしていますが、転記前にはクリアしていません。
なので、マクロブックの"データ入力場所"シートの転記想定領域は、空白にしておいてください。
（転記領域サイズが、必ずしも一定ではないようですのでマクロでの事前のクリアが困難なので）
Sub 円楕円2_Click()
Dim strFileName As String
Dim セル内容, パス名 As String
Dim shT As Worksheet
Dim shF As Worksheet
Dim shM As Worksheet
Dim myR As Range
Dim i As Long
Dim nameV As Variant
Dim CopyV As Variant
Dim NameC As Range
Application.ScreenUpdating = False
Set shM = ActiveSheet
Set shT = ThisWorkbook.Sheets("データ入力場所")
nameV = Array("B4", "B300", "B600", "B900", "B1200", "B1500") '新規ブック名セル
CopyV = Array("A2:R272", "A273:R543", "A544:R815", "A816:R1085", "A1086:R1356", "A1357:R1627") '転記元領域
' オープンする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)
パス名 = CreateObject("WSCript.Shell").SpecialFolders("MyDocuments") '★保存場所
For i = LBound(nameV) To UBound(nameV)
Set NameC = shM.Range(nameV(i)) '保存ブック名セル
Set myR = shF.Range(CopyV(i)) '転記元領域
セル内容 = NameC.Value
myR.Copy shT.Range("A3")
Application.DisplayAlerts = False '同名ブックがあれば無条件上書き
'マクロブックの複製ブックを新規作成
ThisWorkbook.SaveCopyAs パス名 & "\" & セル内容 & ".xlsm"
'次のコピーのため、転記した領域をクリア
shT.Range("A3").Resize(myR.Rows.Count, myR.Columns.Count).ClearContents
Next
shF.Parent.Close False 'CSVファイルを閉じる
Application.ScreenUpdating = True
MsgBox "処理終了"
End Sub
|
|
UO3
- 13/5/15(水) 10:07 -
