エクセルVBAのプログラム

質問

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

noname#9268 · ベストアンサー

今までのは忘れてこれを使ってください

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

shishishishi

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

shishishishi

No5です。

４行目がAとBを誤っていました。
開くのはBでしたね。

Workbooks.Open Filename:=myP & "\B.xls"

に変えてください。
すみません。

回答No.5

shishishishi

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

noname#9268

'データ名と同じなら終了
If Cells(i, 1) = d Then Exit For
を
If Cells(i, 1) = a1 Then Exit For
に変更してください

回答No.2

noname#9268

こちらのバージョンは２００３ですが
他のバージョンでも動作すると思います。

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

回答No.1

noname#9268

別の質問で回答したmao_maoです。

ご事情がご事情なので作ってみます。
しばらくお待ちください。