A.xlsからB.xlsのファイル(最初はA..xlsのみが開いています)へのデータ転送をしたいのですが、プログラムが組めません(>n<)
すみませんが誰か助けてください。
行いたい作業は以下の通りです。
※デスクトップにあるB.xlsを開く
※A.xlsのセル「A1~A5」をコピーしてB.xlsのAの列の列で空欄の行を見つけて、列と行を入れ替えて貼り付ける(もしB.xlsのA10までデータが入力されていたら、貼り付ける場所はA11~F11になります)
※B.xlsは作業終了後自動保存して閉じる
その際に
※A.xlsのセル「A1」にはデータ名が記入されているのでB.xlsのAの列にその名前があれば、そこに上書きする形にしたい。
※A.xlsのA2のセルには「55,23」のように二つの数字が「,」でつながって入力されているので、B.xlsに貼り付けるときには、二つのセルにわけてそれぞれの数字を貼り付けたい。
お手数おかけしますがよろしくお願いいたします。
No.4ベストアンサー
- 回答日時:
今までのは忘れてこれを使ってください
Option Explicit
Sub Macro1()
Dim aname As String
Dim bname As String
Dim a1 As String
Dim a2() As String
Dim a3 As String
Dim a4 As String
Dim a5 As String
Dim i As Long
aname = ActiveWorkbook.Name 'aのファイル名
Workbooks.Open Filename:=ActiveWorkbook.Path & "\" & "b.xls"
bname = ActiveWorkbook.Name 'bのファイル名
Windows(aname).Activate
'データ名(A1)を保存
a1 = Cells(1, 1)
'A2を分割
a2 = Split(Cells(2, 1), ",", -1)
'A3-A5を保存
a3 = Cells(3, 1)
a4 = Cells(4, 1)
a5 = Cells(5, 1)
'bで空いてるところを探す
Windows(bname).Activate
For i = 1 To 65500
'A列が空いていれば終了
If Cells(i, 1) = "" Then Exit For
'データ名と同じなら終了
If Cells(i, 1) = a1 Then Exit For
Next
'貼り付け
Cells(i, 1) = a1
Cells(i, 2) = a2(0)
Cells(i, 3) = a2(1)
Cells(i, 4) = a3
Cells(i, 5) = a4
Cells(i, 6) = a5
'bを保存
ActiveWorkbook.Save
ActiveWindow.Close
End Sub
お礼が遅くなりまして申し訳ありませんでした。
おかげ様で、無事にプログラムを組むことができました。
これを機会に自分でも、もう少しVBAについて勉強してみようと思いました。
大変助かりました。
ありがとうございました。
No.7
- 回答日時:
No5&No6です。
なんどもすみません。
> ※A.xlsのセル「A1」にはデータ名が記入されているのでB.xlsのAの列にその名前があれば、そこに上書きする形にしたい。
この条件を忘れていました。
付け加えました。
Sub test2()
Dim myP, dn, x, y, ws, R
myP = ThisWorkbook.Path
Set ws = ThisWorkbook.Sheets("Sheet1")
dn = ws.Range("A1").Value
ws.Range("A1:A5").Copy
Workbooks.Open Filename:=myP & "\B.xls"
Sheets("Sheet1").Select
Columns("A").Select
Set R = Selection.Find(What:=dn, LookIn:=xlFormulas, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)
If R Is Nothing Then
Sheets("Sheet1").Range("A65536").End(xlUp).Offset(1, 0).Select
Else
R.Select
End If
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, Transpose:=True
Selection.Offset(0, 1).Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, Transpose:=True
x = Sheets("Sheet1").Range("A65536").End(xlUp).Row
y = InStr(Cells(x, "C"), ",")
Cells(x, "B") = Left(Cells(x, "C"), y - 1)
Cells(x, "C") = Mid(Cells(x, "C"), y + 1)
ActiveWorkbook.Save
ActiveWindow.Close (False)
End Sub
お礼が遅くなりまして申し訳ありませんでした。
おかげ様で、無事にプログラムを組むことができました。
大変助かりました。
ありがとうございました。
No.6
- 回答日時:
No5です。
4行目がAとBを誤っていました。
開くのはBでしたね。
Workbooks.Open Filename:=myP & "\B.xls"
に変えてください。
すみません。
No.5
- 回答日時:
A.xlsの標準モジュールに貼り付けてください。
A.xlsとB.xlsは両方とも同じフォルダーに置いてください。
A.xlsのデータはSheet1にあるものとします。
B.xlsのデータはSheet1に貼り付けるものとします。
(シート名は適宜変えて使用してください)
Sub test1()
myP = ThisWorkbook.Path
ThisWorkbook.Sheets("Sheet1").Range("A1:A5").Copy
Workbooks.Open Filename:=myP & "\A.xls"
Sheets("Sheet1").Select
Sheets("Sheet1").Range("A65536").End(xlUp).Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, Transpose:=True
Selection.Offset(0, 1).Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, Transpose:=True
x = Sheets("Sheet1").Range("A65536").End(xlUp).Row
y = InStr(Cells(x, "C"), ",")
Cells(x, "B") = Left(Cells(x, "C"), y - 1)
Cells(x, "C") = Mid(Cells(x, "C"), y + 1)
ActiveWorkbook.Save
ActiveWindow.Close (False)
End Sub
No.3
- 回答日時:
'データ名と同じなら終了
If Cells(i, 1) = d Then Exit For
を
If Cells(i, 1) = a1 Then Exit For
に変更してください
No.2
- 回答日時:
こちらのバージョンは2003ですが
他のバージョンでも動作すると思います。
Sub Macro1()
Dim aname As String
Dim bname As String
Dim a1 As String
Dim a2() As String
Dim a3 As String
Dim a4 As String
Dim a5 As String
Dim i As Long
aname = ActiveWorkbook.Name 'aのファイル名
Workbooks.Open Filename:=ActiveWorkbook.Path & "\" & "b.xls"
bname = ActiveWorkbook.Name 'bのファイル名
Windows(aname).Activate
'データ名(A1)を保存
a1 = Cells(1, 1)
'A2を分割
a2 = Split(Cells(2, 1), ",", -1)
'A3-A5を保存
a3 = Cells(3, 1)
a4 = Cells(4, 1)
a5 = Cells(5, 1)
'bで空いてるところを探す
Windows(bname).Activate
For i = 1 To 65500
'A列が空いていれば終了
If Cells(i, 1) = "" Then Exit For
'データ名と同じなら終了
If Cells(i, 1) = d Then Exit For
Next
'貼り付け
Cells(i, 1) = a1
Cells(i, 2) = a2r(0)
Cells(i, 3) = a2r(1)
Cells(i, 4) = a3
Cells(i, 5) = a4
Cells(i, 6) = a5
'bを保存
ActiveWorkbook.Save
ActiveWindow.Close
End Sub
お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!
似たような質問が見つかりました
- Visual Basic(VBA) エクセルVBA Workbook変数に変数を使ったファイル名を格納したい 5 2023/06/13 14:46
- Visual Basic(VBA) エクセルVBA 既存エクセルを開きその中のシートとしてCSVファイルを開く 3 2023/05/31 13:11
- Excel(エクセル) フォルダ内の全ブックのシート名を変更したい 7 2022/09/22 21:34
- Visual Basic(VBA) DisplayAlertsブロパティで ”実行時エラー424オブジェクトが必要です” 5 2022/05/15 18:02
- Visual Basic(VBA) エクセルVBA エクセルを開いた後に編集可能な状態にするには? 2 2023/06/14 11:58
- Visual Basic(VBA) このVBAでExcelアプリケーションを作成は必要ですか? 3 2023/07/19 21:13
- Visual Basic(VBA) ファイル名の右側を変更したい ファイル名:「1001日別売上」の左側へ「2022」を追加し、「202 6 2022/10/14 10:03
- その他(Microsoft Office) office2010とoffice365の共存でoffice365を優先で起草させたい 3 2023/01/24 10:47
- Excel(エクセル) フォルダ階層が深いファイルの拡張子の一括変換 2 2022/12/23 18:40
- Excel(エクセル) マクロを教えてください 1 2022/11/28 14:52
関連するカテゴリからQ&Aを探す
おすすめ情報
デイリーランキングこのカテゴリの人気デイリーQ&Aランキング
-
あああ..ああい..ああう とい...
-
xlookup関数の引数を利用して検...
-
VBAにて『元に戻すボタン』を作...
-
select caseの入れ子
-
マクロの「SaveAs」でエラーが...
-
VBAマクロ実行時エラーの修正に...
-
Worksheets メソッドは失敗しま...
-
エクセル マクロ オートフィ...
-
B列の最終行までA列をオート...
-
エクセルVBA 配列からセルに「...
-
【ExcelVBA】zip圧縮されたCSV...
-
VBA シートをコピーする際に Co...
-
結合されたセルをプルダウンの...
-
「段」と「行」の違いがよくわ...
-
エクセルで離れた列を選択して...
-
エクセルで複数のシートのクリ...
-
LEFT関数とIF関数の組み合わせ...
-
エクセルで特定の文字列が入っ...
-
vbaで指定したセルより下の行を...
-
VBA 指定した列にある日時デー...
マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング
-
あああ..ああい..ああう とい...
-
VBAバーコード照合 バーコード...
-
VBAにて『元に戻すボタン』を作...
-
select caseの入れ子
-
vbs 文字位置を中央に
-
エクセルで選択したセルがディ...
-
xlookup関数の引数を利用して検...
-
再帰構造のアルゴリズムで困っ...
-
エクセルを開いたらカウントし...
-
スペース区切りのAND検索
-
日付け関数について
-
targetでクリックしたら○
-
VBAにて文字列の長さを取得...
-
1つのテーブルに重複している列...
-
半透明ブラシ重ね塗りのアルゴ...
-
C++で、b[bit]の非負整数(例え...
-
VBAマクロ実行時エラーの修正に...
-
エクセルで特定の文字列が入っ...
-
マクロの「SaveAs」でエラーが...
-
VBA シートをコピーする際に Co...
おすすめ情報