エクセルVBAの書き方を教えてください

Question

エクセル2010を使用しています
エクセルのSheet1に
A列
1-1-1
1-1-2
1-1-3
2-1-1
2-1-2
2-1-3
2-1-4
1600行ほどあります

Sheet2で日付ごとの入金表があります
入金日付がD5セルにあります
C列に
2-1-2
1-1-3
2-1-3
等にランダムに入力されています

Sheet1のB列に入金日を転記するVBAを教えてください

WindFaller · Accepted Answer

こんばんは。

>Sheet1にはSheet2のC5のみ転記され、C2,C3,C4,C6は転記されませんでした。
なるほど! 一つということはないと思っていましたから、案の定でした。
一つ何かを提示しないと、ご質問者さんの反応が、分からないから、簡易的なものを作ったのです。
ところで、色付きのアイデアは、いかがでしたか？もし、問題なければ、それは残しておきます。

前回のSheet2 に入っているマクロは消して、今度は、ActiveX コントロールのボタンに入れるものを考えました。

＊これで、足りない部分や余計な部分があるはずですから、それをご指摘ください。
多少とも、エラーや表の問題をチェックするようには出来ています。
現在は、メッセージボックスで、エラーメッセージが出た後は、その内容は、イミディエイト・ウィンドウの中に保管しています。また、番号の検索データは、セルのオブジェクトになっていますので、もし、その部分に、他に転記したいものがあれば、同じ行数の他列のセルに転記できます。

※ただし、まだ、本番の実行をしないで、サンプルデータで行ってみてください。

'//Sheet2のActiveX コントロールのボタンに付けます
Private Sub CommandButton1_Click()
　Dim ws1 As Worksheet
　Dim ws2 As Worksheet
　Dim Nos() As Variant
　Dim rcDate As Variant
　Dim msg As String
　Dim c As Range
　Dim i As Long, j As Long
　Dim v As Variant
　Dim FirstAddr As String
　
　'******設定**********
　Const FCOLOR As Integer = 14 '濃い緑　フォントに色付け
　Set ws2 = Me
　Set ws1 = Worksheets("Sheet1")
　'******設定**********
　
　ReDim Nos(0)
　Nos(0) = Null 'ダミー
　With ws2
　　For i = 2 To .Cells(Rows.Count, 3).End(xlUp).Row 'C列二行目から
　　　ReDim Preserve Nos(j)
　　　If .Cells(i, 3).Text Like "#*-#*-#*" Then
　　　　Set Nos(j) = .Cells(i, 3)
　　　　j = j + 1
　　　End If
　　Next i
　　For i = 2 To .Cells(Rows.Count, 4).End(xlUp).Row 'D列二行目から
　　　If .Cells(i, 4).Text Like "H##*" Then
　　　　rcDate = .Cells(i, 4).Text '日付は一つしか入らない
　　　　Exit For
　　　End If
　　Next i
　　If IsNull(Nos(0)) Or rcDate = "" Then MsgBox ws2.Name & "の入金データを完全に取得していません。", vbCritical: Exit Sub
　End With
　With ws1
　　.Activate 'シートの切り替わり
　　.Range("A1").Select
　　For Each v In Nos
　　　Set c = .Columns(1).Find(v.Text, , xlValues, xlWhole)
　　　If Not c Is Nothing Then
　　　　If c.Font.ColorIndex <> FCOLOR Then
　　　　　FirstAdd = c.Address
　　　　　c.Offset(, 1).Value = rcDate
　　　　　c.Resize(, 2).Font.ColorIndex = FCOLOR
　　　　　v.Resize(, 1).Font.ColorIndex = 3 '元データにも転記済みなら色を付けた
　　　　　i = Application.CountIf(.Columns(1), v.Text)
　　　　　If i > 1 Then
　　　　　　Do
　　　　　　　Set c = .Columns(1).FindNext(c)
　　　　　　　If c.Address = FirstAdd Then Exit For
　　　　　　　c.Offset(, 1).Value = "重複"
　　　　　　　c.Resize(, 2).Font.ColorIndex = 3
　　　　　　　msg = msg & vbCrLf & c.Text & "は重複しています。" & c.Address(0, 0)
　　　　　　Loop Until c Is Nothing
　　　　　End If
　　　　Else
　　　　　msg = msg & vbCrLf & v.Text & "は、既に入金済になっています。" & c.Address(0, 0)
　　　　End If
　　　Else
　　　　msg = msg & vbCrLf & v.Text & "が見つかりません。"
　　　End If
　　Next v
　End With
　If Trim(msg) <> "" Then
　　MsgBox Mid(msg, 2)
　　Debug.Print msg 'エラー記録は、イミディエイト・ウインドウに入れる(不要ならコメントブロック）
　End If
　Set c = Nothing
　Set ws1 = Nothing
　Set ws2 = Nothing
End Sub
'//
'//おまけ
Sub FomatColorClear()
'フォントの色を一気に消すマクロ
Dim i As Long
For i = 1 To 2
　With Worksheets("Sheet" & i).UsedRange
　 .Font.ColorIndex = xlAutomatic
　End With
Next
End Sub
'//

WindFaller · Answer

こんにちは。

>実行したところ、「Sheet2のデータを完全に取得していません」で止まります。
>前回補足の通り、1日当たりのC列への入力は一定でなく、数個から１００数十個になります。

「入金データを完全に取得していません。」のエラーメッセージは、シート2のC列の番号を拾っていないか、D列の入金日(ひとつしかない）を取得していないか、どちらかだ、という意味です。
C列の番号については100個でも1,000個でも可能です。数の問題ではありません。

C列の番号には、書式パターンの選別があります。
たぶん、サンプルと実際では、内容が違うものだと思われます。
書式パターンを正確におっしゃっていただければ、直しますが、そのパターンを非公開だとおっしゃられるなら、それはそれで方法を変えるか、VBAのヘルプやインターネットで「Like演算子」を調べ、ご自身で作っていただくことになります。

Like "#*-#*-#*"　は、Like 演算子といい、英語で、◎◎のようだという意味があります。
[#] は、数字の意味で、[*] は、その後、何でもあり、ということです。これは、Excel側で、書式でそうなるように作られていても、表示上の文字で判定します。

　If .Cells(i, 3).Text Like "#*-#*-#*" Then　'というのは、以下のように選別します。
「3-4-2」　OK
「12-51-5」　OK
「1a-3b-5」　OK
-----------------
「5」　NG
「a1-5-c」　NG
「1-5」　NG

ということです。不要なデータを入り込ませないためです。入り込めば、見つかりません、となります。

その部分を、
　Like "?*-?*-?*"
　とすれば、「a1-5-c」　の書式パターンは通るようになりますが、他のNGパターンは通りません。

事前に、不要データを避けるエラー回避の方法もあります。簡単にいうと、CountIf 関数を利用するのですが、後からもう一度調べますので、できるだけ避けたいものです。

該当する部分のコード

　　For i = 2 To .Cells(Rows.Count, 3).End(xlUp).Row 'C列二行目から
　　'C列は、行の最後まで入れる
　　　ReDim Preserve Nos(j)
　　　If .Cells(i, 3).Text Like "#*-#*-#*" Then　'←ここの部分。
　　　　Set Nos(j) = .Cells(i, 3)
　　　　j = j + 1
　　　End If
　　Next i

また、D列は、

番号　　入金日
3-4-2　
1-1-2　
1-1-3　入金日
1-2-7　H27.1.10

ひとつ拾ったら、もうそれ以上は入れないようになっています。

　　For i = 2 To .Cells(Rows.Count, 4).End(xlUp).Row 'D列二行目から
　　　If .Cells(i, 4).Text Like "H##*" Then
　　　　rcDate = .Cells(i, 4).Text '日付は一つしか入らない
　　　　Exit For　'←もうデータ探さないということ。
　　　End If
　　Next i

WindFaller · Answer

こんにちは。補足ありがとうございました。なるほど、全体の構図は分かりました。図を見るまで、理解できていませんでした。今は、プロトタイプですから、こういうものを使って、細かい調整が必要になるかもしれませんし、また、大幅に変えたほうがよいかもしれません。まずはたたき台として、提示します。個人的には、他にも方法もあるとは思っていますが、簡単なものを選びました。・コードの貼り付け方と、使い方：これは、Sheet2のタブを右クリックして、「コードの表示」をクリツクし、VBEの画面を出し、そこに貼り付けます。使い方は、Sheet2のセルに一つ入金日を入れたら、Sheet1 側に番号を検索し、転機した入金日と検索された番号のセルに色を付けていくという方法です。入金したものと区別をつけるためで、同じ色がついているとマクロでは、コピー＆ペーストができないようになっています。実用度を増すために、エラー処理はいくつか施してあります。不要なら、取り去ってもよいです。このコードは、キーを入力をした時に発生する信号で、マクロが起動するようになっています。 '//Sheet2　に貼り付ける Private Sub Worksheet_Change(ByVal Target As Range) 　Dim ws1 As Worksheet 　Dim ws2 As Worksheet 　Dim SrchTxt As Variant 　Dim c As Range 　Dim i As Long 　Const FCOLOR As Integer = 14　'濃い緑　フォントに色付け　Set ws2 = Me 　Set ws1 = Worksheets("Sheet1") 　If Target.Column <> 4 Then Exit Sub 　If Not IsDate(Target.Value) Then Exit Sub 　If Target.Offset(, -1).Value = "" Then MsgBox "番号が見当たりません。", vbExclamation: Exit Sub 　SrchTxt = Target.Offset(, -1).Value 　ws1.Activate 'シートの切り替わり　Set c = ws1.Columns(1).Find(SrchTxt, , xlValues, xlWhole) 　If Not c Is Nothing Then 　　c.Select　'セルに飛ぶ　　If c.Font.ColorIndex <> FCOLOR Then 　　　c.Offset(, 1).Value = Target.Text 　　　c.Resize(, 2).Font.ColorIndex = FCOLOR 　　　i = Application.CountIf(ws1.Columns(1), SrchTxt) 　　　If i > 1 Then MsgBox SrchTxt & "は" & i & "個あるようです。", vbExclamation 　　Else 　　　MsgBox SrchTxt & "は、既に入金済になっています。", vbExclamation 　　End If 　Else 　　MsgBox SrchTxt & "が見つかりません。", vbExclamation 　End If 　Set c = Nothing 　Set ws1 = Nothing 　Set ws2 = Nothing End Sub '// なお、まとめて一気にやる方法は、コードが違いますから、その時は、その旨をおっしゃってください。

WindFaller · Answer

こんにちは。

回答にはいたりませんので、その疑問点・問題点を書かせていただきます。

・Sheet1 A列とSheet2 C列にあるものは、なんですか？
1-1-1
1-1-2

一見、日付のようにも見えますが、Excel自体には、このような日付表示は存在しません。
01-1-1　なら、2001年1月1日の意味ですが、1-1-1では日付値とは言えません。

>Sheet1のB列には常に日付データが入っていてそれを上書き更新したいのです。
A列ではなく、B列だと書かれています。

・B列の日付データというのは、どのようなスタイル(書式など）で入っているのでしょうか。
Excel VBAのFindメソッドでは、条件が違うと、日付値は検索できません。そういう場合は、一般的には、関数に頼るしかありません。

・同じく、Sheet2 のD5 に入金日付があるというのですが、日付値を検索して、日付値を上書きしたところで、意味はないはずです。どういう条件と何(元のセル）をもって、何(相手のセル）を上書きするのかわかりません。

残念ですが、今の内容だけでは、解決は不可能だと思います。

ある程度の図を入れて、シミュレートできるようになれば、すぐに、その先に進むと思います。

また、ご自身で、記録マクロなどで記録をしたもので、状況説明するか、関数では、こういう式になるのが、上書きを必要とするので、二度手間になるから、マクロにしてほしいとか、位置関係を入れ、より具体性をもった、質問していただくようにしてください。

基本的に、人がPCに向かって手動で行うものは、概ね、プログラミングが可能です。言い換えれば、回答者の能力の範囲なら、人が手でやっていることを、目が見えない人でも分かるように、言葉で教えていただければ可能だということです。

なお、私の読み落としがあるのでしたら、ご容赦のほどお願いします。
よろしくお願いします。

High_Score · Answer

入金日付はD5セルではなく、D列の誤りですね？それ前提で回答します。
Sheet1B列先頭、ここではB2としますが、

=vlookup(A2, Sheet2!C:C, 2,0)

と入力し、1600行までズイッと引っ張ります。
あ、スミマセンVBAでしたか。やることは同じです。

Sub Macro1()
Dim Lastrow as Long
Lastrow=Cells(Rows.Count,1).End(xlUp).Row
Range("B2").Resize(Lastrow-1,1).Formula="=vlookup(A2, Sheet2!C:C, 2,0)"
Endsub

エクセルVBAの書き方を教えてください

こんばんは。

こんにちは。

こんにちは。

こんにちは。

入金日付はD5セルではなく、D列の誤りですね？それ前提で回答します。

似たような質問が見つかりました

関連するカテゴリからQ&Aを探す

デイリーランキングこのカテゴリの人気デイリーQ&Aランキング

マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング