[[20221118224914]]　『名前を指定したブックから新規ブックへ値をコピー』（AIMS）　ページの最後に飛ぶ

『名前を指定したブックから新規ブックへ値をコピー』（AIMS）

お世話になります。

やりたいこと

コピー元.xlsm　デスクトップにあるブック
コピペ.xlsm　この質問のマクロが付いているブック
コピー先.xlsx　新規作成されるブック

1　デスクトップ上にあるコピー元.xlsmのsheet1の値をコピー先.xlsxのsheet1へコピーする
2　コピー先.xlsxを保存する　ファイル名の末尾に（1）をつけて重複防止する
3　コピーする際QTYのコンマ以下の削除
4　コピーする際SPECの末尾4桁の削除

現状
コピー元.xlsmの名前をコピペ.xlsmのA1へ入力するとコピー先.xlsxを新規作成する

参考にしたHPなど
保存の部分
https://www.excel.studio-kazu.jp/kw/20220927165342.html

コピー元.xlsmのsheet1の内容

 　　　A　　　B　　　　　C　　　　　E　　　　F　　　　　G
 1　REF　　　NO　　　　CODE　　　　DESC　　SPEC　 　　　QTY
 2　ABC123　　1　　　　SCREW　　　　ASP1　　 F4\\\\　　　3.0000
 3　ABC123　　2　　　　LINE 　　　　PV5　　　F4\\\\　　　3.0000
 4　ABC123　　3　　　　STEP 　　　　PV3　　　F4\\\\　　　3.0000
 5　ABC123　　4　　　　SCREW　　　　ASP7　　 F4\\\\　　　3.0000

コピー先.xlsxのsheet1の内容

 　　　A　　　B　　　　　C　　　　　E　　　　F　　　　　G
 1　REF　　　NO　　　　DESC　　　　CODE　　SPEC　 　　　QTY
 2　
 3　空白のシート　この並びでコピーしたい
 4　
 5

コピペ.xlsmの内容

 　A　B　C
 1
 2↑A1にコピー元の名前を入力すること
 3マクロ実行ボタン

A1にコピー元ブックの名前を入力します
A2は注意書きの文章です
A3にマクロ実行のボタンがあります

Sub コピペ()

Dim cell As String
Dim LastRow As Long
Dim wb As Workbook
Dim moto As Workbook

cell = Range("A1").Value & ".xlsm"

Workbooks.Open Filename:="C:\Users\ABC\Desktop\" & cell

Set wb = Workbooks.Add

ここからうまくできません
C:\Users\ABC\Desktop\" & cellでコピー元のブックを開くことはできるのですが、どうやって変数を設定すればよいのでしょうか。
こういうような感じでコピーと保存すると思うのですが....どうでしょうか

Dim rowsData As Long '行数カウント用の変数

rowsData = moto.Cells(Rows.Count, 1).End(xlUp).Row

k = 1

    For i = 1 To rowsData
        'REFのコピー
        wb.Sheet1.Cells(k, 1).Value = moto.Sheet1.Cells(i, 1).Value
　　　　'NOのコピー
        wb.Sheet1.Cells(k, 2).Value = moto.Sheet1.Cells(i, 2).Value
　　　　'DESCのコピー
        wb.Sheet1.Cells(k, 3).Value = moto.Sheet1.Cells(i, 4).Value
        'CODEのコピー
        wb.Sheet1.Cells(k, 4).Value = moto.Sheet1.Cells(i, 3).Value
　　　　'SPECのコピー
        wb.Sheet1.Cells(k, 5).Value = moto.Sheet1.Cells(i, 5).Value
　　　　'QTYのコピー
        wb.Sheet1.Cells(k, 6).Value = moto.Sheet1.Cells(i, 6).Value

        k = k + 1

    Next i

Const SavePath = "C:\Users\ABC\Desktop\TEST\TEST\"

Dim FileName As String
Dim i As Integer

FileName = SavePath & "AAA-" & Worksheets("sheet1").Range("A2").Value & ".xlsx"

Do While Dir(FileName) <> ""

    i = i + 1
    FileName = SavePath & "AAA-" & Worksheets("sheet1").Range("A2").Value & Format(i, "(0)") & ".xlsx"
Loop

ThisWorkbook.SaveCopyAs FileName:=FileName

end sub

＜使用 Excel：Excel2019、使用 OS：Windows10 ＞

 最初の辺りだけです。

 ＞どうやって変数を設定すればよいのでしょうか。
 ブックを開いた後なので、
 Set moto = Workbooks(cell)
 でどうでしょうか。

 ＞rowsData = moto.Cells(Rows.Count, 1).End(xlUp).Row
 変数 moto はブックなので、
 rowsData = moto.Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
                 ~~~~~~~~~~~~~~~~~~~~
 上記の様に、シートを指定してからセルを指定しないと、エラーになります。

 ※訂正不要な箇所がありましたので削除しました。
（wss） 2022/11/20(日) 07:18:49

↓のように考えてみてはどうでしょうか？

 1.　データ元となるブックを開く

 2.　出力先となるブックを開く（新規ブックを追加する）

 3.　【フィルタオプション】で列を入れ替えながら[1]から[2]のブックへ情報を転記する

 4.　[1]のブックは用済みなので、保存せずに閉じる

 5.　[2]のブックの"sheet1"について、2行目から最終行まで順番にみていき
     　F列を右から4文字を除いたものに書き換える（左から２文字を取り出す）
     　G列を小数点以下を切り捨てたものに書き換える

 6.　[5]を名前を付けて保存する

（もこな２） 2022/11/20(日) 11:35:34

wssさん、もこな２さん
返事が遅くなってしまいました。
ありがとうございます。
動くマクロが作れたらここに書き込みます。

（AIMS） 2022/11/20(日) 16:13:45

やりたいこと

コピー元.xlsm　デスクトップにあるブック
コピペ.xlsm　この質問のマクロが付いているブック
コピー先.xlsx　新規作成されるブック

現状
やりたいこと1　できた
やりたいこと2　できた
やりたいこと3　以下のマクロを実行するとなぜかコンマ以下が削除されてコピーされる
　　　　　　　　原因はわからないけどやりたいことはできている
やりたいこと4　できた　もっと簡単なやり方があると思いますが、私の思いつく方法はこれしかありませんでした

つたないマクロなので参考になるかわかりませんが、以下に書き残しておきます。

Sub コピペ()

Dim cell As String '元のブックの呼び出し
Dim moto As Workbook '元のブック
Dim LastRow As Long
Dim wb As Workbook '新規ブック
Dim wbLastRow As Long '新規ブックの最終行

cell = Range("A1").Value & ".xlsm"

Workbooks.Open FileName:="C:\Users\ABC\Desktop\" & cell

Set wb = Workbooks.Add

Set moto = Workbooks(cell)

'変数 moto はブックなのでシートを指定してからセルを指定すること
LastRow = moto.Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row

'元からコピペ

k = 1

    For i = 2 To LastRow
        'REF
        wb.Worksheets("Sheet1").Cells(k, 1).Value = moto.Worksheets("Sheet1").Cells(i, 1).Value
        'NO
        wb.Worksheets("Sheet1").Cells(k, 2).Value = moto.Worksheets("Sheet1").Cells(i, 2).Value
        'DESC
        wb.Worksheets("Sheet1").Cells(k, 3).Value = moto.Worksheets("Sheet1").Cells(i, 4).Value
        'CODE
        wb.Worksheets("Sheet1").Cells(k, 4).Value = moto.Worksheets("Sheet1").Cells(i, 3).Value
        'SPEC
        wb.Worksheets("Sheet1").Cells(k, 5).Value = moto.Worksheets("Sheet1").Cells(i, 5).Value
        'QTY
        wb.Worksheets("Sheet1").Cells(k, 6).Value = moto.Worksheets("Sheet1").Cells(i, 6).Value

        k = k + 1

    Next i

'新規ブックの最終行
wbLastRow = wb.Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row

'SPEC末尾の削除

'SPEC末尾の文字列削除の作業列を追加
wb.Worksheets("Sheet1").Range("F2").EntireColumn.Insert
'作業列にてSPEC末尾の削除
wb.Worksheets("Sheet1").Range("F2:F" & wbLastRow) = "=LEFT(E2, LEN(E2)-4)"
'作業列のデータをコピー
wb.Worksheets("Sheet1").Range("E2:E" & wbLastRow).Value = wb.Worksheets("Sheet1").Range("F2:F" & wbLastRow).Value
'作業列の削除
wb.Worksheets("Sheet1").Columns(6).Delete

'保存重複防止
'Dim Ref As String
'Ref = wb.Worksheets("Sheet1").Range("A2").Value
'ActiveWorkbook.SaveAs FileName:="C:\Users\ABC\Desktop\TEST\" & Ref

Const SavePath = "C:\Users\ABC\Desktop\TEST\"

Dim FileName As String
Dim n As Integer

FileName = SavePath & wb.Worksheets("sheet1").Range("A2").Value & ".xlsx"

Do While Dir(FileName) <> ""

    n = n + 1
    FileName = SavePath & Worksheets("sheet1").Range("A2").Value & Format(n, "(0)") & ".xlsx"
Loop

ActiveWorkbook.SaveAs FileName:=FileName

End Sub

wssさん、もこな２さん
アドバイスありがとうございました。
やりたいことが全て達成できてすっきりしました。
（AIMS） 2022/11/20(日) 22:00:58

コメント返信：

[ 一覧(最新更新順) ]

[[20221118224914]] 『名前を指定したブックから新規ブックへ値をコピー』（AIMS） ページの最後に飛ぶ

[[20221118224914]]　『名前を指定したブックから新規ブックへ値をコピー』（AIMS）　ページの最後に飛ぶ