VBA初心者です。シート"M"からA列の契約番号の複数必要データを変数入力し、別シート"A"に場所を探した出したうえで転記するプログラムが動きません。改良点が分からず困っております。どなたかご教示いただけると大変助かります。
(具体的な内容)
シート"M"は元のデータが入っているシートです。このシートのA列に入っている契約番号の行の列にある複数コラムのデータを、同ブック内にあるシート”A”にある表に、契約番号を検索キーにし検索し場所を探し出し後、転記をするプログラムを組もうとしましたが以下の状況が発生しうまく動きませんでした。
私の以下のプログラムでは、シート"M"で必要な情報を変数var1, var2,var3,var4に代入した後、シート”A”に移り、検索キーとなるシート"A"内の契約番号を If r.Value = var1 という数式の内容で探し出そうとしています。
この過程をWatchウィンドウで確認したところ同じ文字列が入っているにもかかわらず、同一とみなされずデータの転記をせずに通り過ぎてしまいました。
何が悪いのでしょうか。いろいろと手を変え品を変え試しましたがうまく動かず困っています。
ご教示いただけますと大変助かります。 どうかよろしくお願いいたします。
--------------------------------------
Sub データ転記プログラムテスト()
'変数宣言
Dim sh1, sh2
Set sh1 = Worksheets("M")
Set sh2 = Worksheets("A")
Dim 先頭行 As Long
Dim 末尾行 As Long
Dim 行番号 As Long
Dim var1 As String
Dim r As Range
sh1.Select
'データの一行目から1列目、3列目のデータを変数var1, var2に取り込む
先頭行 = 2
末尾行 = Range("A1").CurrentRegion.Rows.Count
For 行番号 = 先頭行 To 末尾行 Step 1
var1 = Cells(行番号, 1)
var2 = Cells(行番号, 9)
'var3 = Cells(行番号, 10)
'var4 = Cells(行番号, 11)
sh2.Select
On Error Resume Next
'---Sheet2で該当行を探す
For Each r In Range("A6:A216")
If r.Value = var1 Then '←ここでr.Value とvar1が同じデータが入っているのに違うとみなされます。どのように対処すればよいでしょうか。(Watch Windowで同じ値が入っていることを確認済みです。)
r.Font.Color = vbBlue
sh2.Cells(r, "J") = var2
sh2.Range("J" & r).Font.Color = RGB(0, 112, 192)
sh2.Cells(r, "K") = var3
sh2.Range("K" & r).Font.Color = RGB(0, 112, 192)
sh2.Cells(r, "L") = var4
sh2.Range("L" & r).Font.Color = RGB(0, 112, 192)
'ActiveCell.Select
'Selection.Font.ColorIndex = 5
Else
End If
Next r
If 行番号 = 末尾行 Then
MsgBox ("データ転記が終了しました")
End If
Next 行番号
End Sub
No.2ベストアンサー
- 回答日時:
No.1です。
コードをよく見させてもらいました。
結局こういうコトをしたいのでしょうか?
Sheet「A」のA列に重複がないのであれば簡単ですが、そこら辺は実際のデータが判らないので
コードで判断して、両方のコードを載せておきます。
標準モジュールにコピー&ペーストしてマクロを試してみてください。
Sub Sample1() 'Sheet「M」に重複がない場合
Dim i As Long, k As Long, c As Range
Dim wS1 As Worksheet, wS2 As Worksheet, myArray
Set wS1 = Worksheets("M")
Set wS2 = Worksheets("A")
For i = 2 To wS1.Cells(Rows.Count, "A").End(xlUp).Row
Set c = Range(wS2.Cells(6, "A"), wS2.Cells(216, "A")).Find(what:=wS1.Cells(i, "A"), LookIn:=xlValues, lookat:=xlWhole)
If Not c Is Nothing Then
wS2.Cells(c.Row, "A").Font.Color = vbBlue
With wS2.Cells(c.Row, "J").Resize(, 3)
.Value = wS1.Cells(i, "I").Resize(, 3).Value
.Font.Color = RGB(0, 112, 192)
End With
End If
Next i
End Sub
Sub Sample2() 'Sheet「M」に重複がある場合
Dim i As Long, k As Long, wS1 As Worksheet, wS2 As Worksheet
Set wS1 = Worksheets("M")
Set wS2 = Worksheets("A")
For i = 2 To wS1.Cells(Rows.Count, "A").End(xlUp).Row
For k = 6 To 216
If wS1.Cells(i, "A") = wS2.Cells(k, "A") Then
wS2.Cells(k, "A").Font.Color = vbBlue
With wS2.Cells(k, "J").Resize(, 3)
.Value = wS1.Cells(i, "I").Resize(, 3).Value
.Font.Color = RGB(0, 112, 192)
End With
End If
Next k
Next i
End Sub
※ 実際のレイアウトが判れば具体的なアドバイスができると思います。
まずはこの程度で・・・m(_ _)m
他にいただいたアドバイスでもうまく動かなかったのでいただいたコードを使わせていただきました。
いままで1時間以上かけていた作業が一瞬でおわり、感謝の一言に尽きます。このコードを転用させていただきます。
本当にありがとうございました。
No.5
- 回答日時:
> If r.Value = var1 Then
変数の型とか大丈夫なんでしょうか
同じ値なのかどうか、VBA ではなく EXCEL さんにやってもらうとか
以下でどうなりますか
Public Sub Samp1()
Dim ws As Worksheet
Dim iRow As Long
Dim rng As Range, r As Range
Const CCMOJI As String = "=IF(RC[+1]=A!R{%1}C1,1,"""")"
Set ws = Worksheets("A")
Worksheets("M").Select
Columns(1).Insert
With Range("A6:A216")
For iRow = 2 To ws.Range("A1").CurrentRegion.Rows.Count
.FormulaR1C1 = Replace(CCMOJI, "{%1}", iRow)
.Value = .Value
On Error Resume Next
Set rng = .SpecialCells(xlCellTypeConstants, xlNumbers)
If (Err = 0) Then
For Each r In rng
r.Offset(, 1).Font.Color = vbBlue
With r.Offset(, 10).Resize(, 3)
.Value = ws.Cells(iRow, 9).Resize(, 3).Value
.Font.Color = RGB(0, 112, 192)
End With
Next
End If
Next
End With
Columns(1).Delete
Set ws = Nothing
End Sub
シート「M」に作業用の列を1列目に入れて
・隣のものと、シート「A」の比較対象のものが同じなら 1 を
結果を即値にして、数値部分を抽出して・・・・
数値のものがなかったらエラーになるので・・・・
No.4
- 回答日時:
気が付いた点をモジュール内部に記入してみました。
〇第一の問題点は「Range("A6:A216")」で、これではsh1を調べています。sh2.Range("A6:A216") とします。
〇また、「r」はRangeですが、「sh2.Cells(r, "J") = var2」では、このセルの値を書き換えの行番号にしています。多分違うと思うので探した行を「rw」で定義しています。
差し出がましいですが、他に
〇書き換えで、CellsとRangeがあるので統一しました。
〇For~Next でNextの次の変数はない方がすっきりします。
〇「On Error Resume Next」だと、エラーが起きても正常に終わります。
〇For Loopの中で最終行を判定してメッセージを出していますが、ループの外がいいでしょう。このとき「行番号=末尾行+1」です。
〇For Loopの「Step1」は不要です。
Sub データ転記プログラムテスト()
'変数宣言
Dim sh1, sh2
Set sh1 = Worksheets("M")
Set sh2 = Worksheets("A")
Dim 先頭行 As Long
Dim 末尾行 As Long
Dim 行番号 As Long
Dim var1 As String, var2 As String, var3 As String, var4 As String
Dim r As Range
Dim rw As Long '// *** 追記 ***
sh1.Select
'データの一行目から1列目、3列目のデータを変数var1, var2に取り込む
先頭行 = 2
末尾行 = Range("A1").CurrentRegion.Rows.Count
For 行番号 = 先頭行 To 末尾行 Step 1 '// Step 1 は不要
var1 = sh1.Cells(行番号, 1) '// 分かりやすくするために追記
var2 = sh1.Cells(行番号, 9) '// 分かりやすくするために追記
var3 = sh1.Cells(行番号, 10) '// 分かりやすくするために追記
var4 = sh1.Cells(行番号, 11) '// 分かりやすくするために追記
'sh2.Select '// sh2 を定義しているのだから無くていい
On Error Resume Next '// エラーがあっても正常終了させる?
'---Sheet2で該当行を探す
For Each r In sh2.Range("A6:A216") '// sh2. 追記
If r.Value = var1 Then
rw = r.Row '// 見つけた行
r.Font.Color = vbBlue
sh2.Range("J" & rw) = var2
sh2.Range("J" & rw).Font.Color = RGB(0, 112, 192)
sh2.Range("K" & rw) = var3
sh2.Range("K" & rw).Font.Color = RGB(0, 112, 192)
sh2.Range("L" & rw) = var4
sh2.Range("L" & rw).Font.Color = RGB(0, 112, 192)
'ActiveCell.Select
'Selection.Font.ColorIndex = 5
Else
End If
Next
Next
MsgBox ("データ転記が終了しました")
End Sub
No.3
- 回答日時:
こんばんは。
#1さんのいうトラブルが発生していることがあります。
(#2で既に出ているので、私は、あえてサンプルコードは書きません。)
標準モジュールで書いていたら、
ループの外で、sh1.Select をしているのですから、ループの中では、
var1 = Cells(行番号, 1) は、最初は、sh1だったのが、二度目からは、sh2になっていますね。
シートモジュールで書いたら、Range("A6:A216")は、sh2.Select にしても、sh1を参照しているはずです。
どちらにしても、標準モジュールで、sh1 , sh2 をはっきりさせて書かなくてはなりませんね。
次は、参考までに……。
> If r.Value = var1 という数式の内容で探し出そうとしています。
「検索キーとなるシート"A"内の契約番号」というのは、数字だけですか?
それとも、アルファベットや空白が入っているのではないでしょうか?
以下の例は、A1 に、"a" といれ、B1に、"A " ←空白が入っている
それでも、以下なら、同じだと出力されます。私は、こんなコードを使って文字列比較をします。
'//
Sub Test1()
Dim Chr1 As String
Dim sVal As String
Chr1 = Trim(Range("A1").Value) '←ここがミソ1: Trim で空白を取る
sVal = Trim(Range("B1").Value)
If Chr1 <> "" And sVal <> "" Then
If StrComp(Chr1, sVal, vbTextCompare) = 0 Then '←ここがミソ2:TextCompareをする
MsgBox "Same", vbInformation
Else
MsgBox "Different", vbExclamation
End If
End If
End Sub
'//
ご教示ありがとうございます。ご指摘のとおり検索キーは文字列と数字列の混合で、ご教示いただいた空白等を処理するルーチンは大変勉強になりました。どうもありがとうございました。
No.1
- 回答日時:
こんばんは!
コードをざっと拝見して・・・
>var1 = Cells(行番号, 1)
>var2 = Cells(行番号, 9)
>var3 = Cells(行番号, 10)
>var4 = Cells(行番号, 11)
の行がSheetの指定がないので、アクティブSheetが対象になっていると思われます。
丁寧に
>var1 = sh2.Cells(行番号, 1)
>var2 = sh2.Cells(行番号, 9)
>var3 = sh2.Cells(行番号, 10)
>var4 = sh2.Cells(行番号, 11)
のようにSheetを指定したらどうなりますか?
詳しく検証していませんので
他の原因ならごめんなさいね。m(_ _)m
早速のご教示ありがとうございます。
ここの部分はvar1からvar4に変数が代入されているので
うまく稼動しているようです。
うまく動いていないのはこれより下の部分なので
他にもし思い浮かぶご助言がありましたらよろしくお願いいたします。
ほそたに
お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!
似たような質問が見つかりました
- Visual Basic(VBA) 2つのシートの任意のセルの番号が一致したら、一致した行をコピーする VBA 2 2023/06/19 20:48
- Visual Basic(VBA) VBAで最新のデータを別シートに転記する方法をお教えください。 3 2022/04/07 19:20
- Visual Basic(VBA) VBA Userformで一部別シートに転記がしたいのですが 2 2023/05/24 13:08
- Visual Basic(VBA) ユーザーフォーム「frm_基本❶」を立ち上げると新規で入力する行数を右下のNoとして表示しています。 1 2023/03/16 19:02
- Visual Basic(VBA) 【ご教示ください】VBAの記述方法がわかりません。 2 2022/08/12 21:28
- Visual Basic(VBA) VBAコードが作動せず、どこに問題があるのか教えて下さい。 3 2023/06/13 13:20
- Visual Basic(VBA) VBAで質問ですが、皆さんはどの様に導き出しているのでしょうか? 6 2022/05/03 21:53
- Visual Basic(VBA) いつもお世話になっております、VBAで教えて頂きたいのですが 2 2022/05/05 22:20
- Visual Basic(VBA) vba 重複データ合算 5 2023/07/05 18:55
- Visual Basic(VBA) ファイル全てを .xlsm に変更したところ、プログラムが途中で落ちてしまっています 17 2022/12/07 12:03
このQ&Aを見た人はこんなQ&Aも見ています
-
プロが教えるわが家の防犯対策術!
ホームセキュリティのプロが、家庭の防犯対策を真剣に考える 2組のご夫婦へ実際の防犯対策術をご紹介!どうすれば家と家族を守れるのかを教えます!
-
同じ文字列なのにfalseになってしまいます。
Excel(エクセル)
-
VBA 判定文で理解できない結果になる
その他(Microsoft Office)
-
ExcelのVBA。public変数の値が消える
Visual Basic(VBA)
-
-
4
VBA 列全体を別シートの列と比較し、同じ値がある行の、右端に値をコピーする方法について
Excel(エクセル)
-
5
Excel VBAでのWorksheet_Changeが動作しない原因
Excel(エクセル)
-
6
エクセルのエラーメッセージ「400」って?
Visual Basic(VBA)
-
7
Excelでセル参照したとき、書式も一緒に持ってくるには?
Windows Vista・XP
-
8
EXCEL VBAで全選択範囲の解除
Excel(エクセル)
-
9
VBAで先月、先々月を求める方法
Visual Basic(VBA)
-
10
VBAでエクセルシートを更新(リフレッシュ)する方法を教えて下さい。
Excel(エクセル)
-
11
exeファイルの中身を見ることは可能ですか?
フリーソフト
-
12
ファイル名「1.jpg ~10.jpg~」のソート
Visual Basic(VBA)
-
13
Excel VBA IF文がうまく動作しないわけがわかりません…
Visual Basic(VBA)
-
14
エクセルファイルのシート毎の容量
Excel(エクセル)
-
15
VBAでブックを非表示で開いて処理して閉じる方法
Excel(エクセル)
-
16
VBAで保存しないで閉じると空のBookが残る
Excel(エクセル)
-
17
エクセルVBAでセルに入力したパスでブックを開く
Excel(エクセル)
-
18
VBAでファイルを開くときにファイル名でワイルドカードを使用したいです
その他(プログラミング・Web制作)
-
19
i=cells(Rows.Count, 1)とi=cells(Rows.Count, 2)の違い
Visual Basic(VBA)
-
20
【Excel VBA】CSV取込時、数字の先頭の0を消えないようにするには?
Excel(エクセル)
関連するカテゴリからQ&Aを探す
おすすめ情報
このQ&Aを見た人がよく見るQ&A
デイリーランキングこのカテゴリの人気デイリーQ&Aランキング
-
シャープのアクオス sh-m25 を...
-
excelの差込印刷で可視セルだけ...
-
エクセルVBAでの日付順のデ...
-
VBAの処理が途中で止まる
-
歯抜けの時間を埋めて行の挿入
-
エコウォッシュシステムの値段...
-
スマホで古いPCにテザリング
-
VBA 貼付先範囲(行)がいっぱ...
-
エクセルVBA 別シートの複数の...
-
複数条件に一致したデータを月...
-
VBA:同じ文字列データの比...
-
VBAで複雑な構成の転記
-
Excel で行を指定回数だけコピ...
-
ノートパソコン 2in1について i...
-
エクセルVBAで SendKeys "{TAB}"
-
vbaでコントロールブレイク
-
情報系の授業の課題なのですが...
-
LAVIE Direct DT PC-GD298ZZAL...
-
スマホ機種変更で旧機種のGoogl...
-
外付けHDDをフローリングに落と...
マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング
-
エクセルVBA 別シートの複数の...
-
Excel で行を指定回数だけコピ...
-
Excel VBA インデックスの境...
-
excelの差込印刷で可視セルだけ...
-
VBA:同じ文字列データの比...
-
VBA別シートの最終行の下行へ貼...
-
エクセル:VBAで月変わりで、自...
-
エクセルVBAで 2種のリストを...
-
歯抜けの時間を埋めて行の挿入
-
エクセルVBAで SendKeys "{TAB}"
-
VBAで条件が一致する行のデータ...
-
EXCELマクロで全シート対...
-
VBAの指示の内容 昨日こちらで...
-
Excel VBAでシート内全体に非表...
-
VBAで複数シート選択
-
Excelマクロ データが上書きさ...
-
Excel VBA 時刻でのD...
-
VBA 貼付先範囲(行)がいっぱ...
-
エクセルVBAでの日付順のデ...
-
【WORD差し込み印刷】複数レコ...
おすすめ情報