エクセルのSheet1のA列にある文字列と、Sheet2にあるA列にある文字列と完全一致したら、前者のセルの右右右隣セル（一致したセルから数えて４番目のセル）から３番目までのセルに、後者のセルの右隣セル（一致したセルから数えて２番目のセル）から３番目までの文字列を順に代入するマクロをお教えください。つまり代入開始セルをSheet1のD列にしたいのです。（実は任意の列からにしたのですが…）。単純にvlookup関数を使えばいいのですが、ＶＢＡで行いたいのです。
一致したセルの右隣のセルから順に代入するマクロは以下で解決済みです。以下のマクロを編集して実行したいのですが、どこをいじったらよいかわかりません。
なお、代入したいセルを右の任意のセルまで引き延ばしたい場合、以下のコード任意Loop Until Coln1 = 4の右辺の数字を変更すればよいことまではわかっています。どうぞ、よろしくお願い申し上げます。
----------------
Sub 試験()
Dim Row1 As Integer
Dim Coln1 As Integer
Dim Row2 As Integer
Dim Coln2 As Integer
Set WS1 = Worksheets("Sheet1")
Set WS2 = Worksheets("Sheet2")
Coln1 = 1
Coln2 = 1
For Row1 = 1 To WS1.Cells(Rows.Count, 1).End(xlUp).Row
For Row2 = 1 To WS2.Cells(Rows.Count, 1).End(xlUp).Row
If WS2.Cells(Row2, 1) = WS1.Cells(Row1, 1) Then
Do
Coln1 = Coln1 + 1
Coln2 = Coln2 + 1
WS1.Cells(Row1, Coln1) = WS2.Cells(Row2, Coln2)
Loop Until Coln1 = 4
Coln1 = 1
Coln2 = 1
End If
Next Row2
Next Row1
End Sub
エクセルのSheet1のA列にある文字列と、Sheet2にあるA列にある文字列と完全一致したら、前者のセルの右右右隣セル（一致したセルから数えて４番目のセル）から３番目までのセルに、後者のセルの右隣セル（一致したセルから数えて２番目のセル）から３番目までの文字列を順に代入するマクロをお教えください。つまり代入開始セルをSheet1のD列にしたいのです。（実は任意の列からにしたのですが…）。単純にvlookup関数を使えばいいのですが、ＶＢＡで行いたいのです。
一致したセルの右隣のセルから順に代入するマクロは以下で解決済みです。以下のマクロを編集して実行したいのですが、どこをいじったらよいかわかりません。
なお、代入したいセルを右の任意のセルまで引き延ばしたい場合、以下のコード任意Loop Until Coln1 = 4の右辺の数字を変更すればよいことまではわかっています。どうぞ、よろしくお願い申し上げます。
----------------
Sub 試験()
Dim Row1 As Integer
Dim Coln1 As Integer
Dim Row2 As Integer
Dim Coln2 As Integer
Set WS1 = Worksheets("Sheet1")
Set WS2 = Worksheets("Sheet2")
Coln1 = 1
Coln2 = 1
For Row1 = 1 To WS1.Cells(Rows.Count, 1).End(xlUp).Row
For Row2 = 1 To WS2.Cells(Rows.Count, 1).End(xlUp).Row
If WS2.Cells(Row2, 1) = WS1.Cells(Row1, 1) Then
Do
Coln1 = Coln1 + 1
Coln2 = Coln2 + 1
WS1.Cells(Row1, Coln1) = WS2.Cells(Row2, Coln2)
Loop Until Coln1 = 4
Coln1 = 1
Coln2 = 1
End If
Next Row2
Next Row1
End Sub
まだVBAに慣れていませんが、下記のソースを書いてみました。
★印の間の部分の処理を、最初はFor Nextで書いていたのですが、理由が解らないですが…うまく処理されない為、タイトルの2種類（セルのFindメソッドとMatch関数)を使って処理しようと思い書き直したのですがうまく処理されません。
どこがいけないのか解らず数時間も悩んでしまいました。
すみませんが、どなたか教えてください。よろしくお願いします。
Sub 外注別案内書作成()
Dim ws As Worksheet 'オブジェクト格納
Dim i As Long, j As Long '繰り返す回数格納
Dim annaicode As Variant '案内場所C格納
Dim addwsname As Variant 'シート名前格納(※案内場所名)
Dim flag As Boolean '真偽
Dim r As Range 'Findメソッドの返り値格納
Dim K As Long 'Match関数の返り値格納
'レポート元でQ列の情報が入っている時に、案内場所別で情報を作成する。
'レポート元でQ列に値がある時に、annaicode変数へ格納。
For i = 2 To Worksheets("レポート元").Cells(Rows.Count, "A").End(xlUp).Row
If Cells(i, "Q").Value <> "" Then
annaicode = Cells(i, "Q").Value
End If
★ココから--------
'外注一覧でannai変数と一致した時に、addwsname変数へ格納。 FindメソッドとMatch関数
With Worksheets("外注一覧").Columns("1:1")
Set r = .Find(What:=annaicode, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByColumns)
If r Is Nothing Then
MsgBox i & "行目の案内場所Cの入力が不正です。" & vbCrLf & "処理を中断しますね", _
vbOKOnly + vbExclamation, "お知らせ"
Else
With Worksheets("外注一覧")
K = .Match(annaicode, .Range(.Cells(1, "A").Value, .Cells(.Rows.Count, "A").Value), 0)
addwsname = .Cells(K, "B").Value + "_案内"
End With
End If
End With
★ココまで--------
'ワークシートコレクション内でaddwsname変数と一致した時に、flag変数をTrueにする。
For Each ws In Worksheets
If ws.Name = addwsname Then
flag = True
End If
Next ws
'flag変数の値により、各々処理をする。
If flag = True Then
Worksheets("レポート元").Cells(i, "A").EntireRow.Copy _
Destination:=Worksheets(addwsname).Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
flag = False
Else
Worksheets.Add
ActiveSheet.Name = addwsname
Worksheets("レポート元").Cells(i, "A").EntireRow.Copy _
Destination:=Worksheets(addwsname).Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
End If
Next i
End Sub
VBA初心者です。
同じセルに数字を入れて足し算して行きたいんですが！
下記のVBA見つけたのですが、A1に数字を入れて答えがE1に出るんですが、同じ事を
A2、A3、A4、A5答えもE2、E3......で増やしたいのですが、どうするか分かりません。
どなたか教えてください。
宜しくお願いします。
Private Sub Worksheet_Change(ByVal Target As Range)
Dim inp, outp As String
inp = "$A$1"
outp = "E1"
Application.EnableEvents = False
If Target.Address = inp Then
Range(outp).Value = Range(outp).Value + Target.Value
If Target.Value <> "" Then
ActiveCell.Offset(-1, 0).Select
Else
Range(outp).Value = 0
End If
End If
Application.EnableEvents = True
End Sub
Excel画面のA1～A10を10～1の表示にさせるため、VBAを
Sub ***()
Worksheets("Sheet1").Activate
Cells.Clear
Dim i As Integer, n As Integer
For i = 10 To 1 Step -1
Cells(i, 1).Value = i
Next i
End Sub
としたのですが、実際に表示するとA1から1～１０と1ずつ加算されてしまいます。
マイナス値は-1の表示で可能だといろいろ調べてわかったのですが、実際にやるとうまくいきません。
どこが間違っているのでしょうか？
学習不足ではありますが、よろしくお願いします。
