こんにちはゲストさん。会員登録(無料)して質問・回答してみよう!

解決済みの質問

エクセル マクロ修正

シート1~5まであります。別に情報シートを作成しています
それぞれ同じ原本から作成しています

全部のシートにA1~A10のセルに日付、B1~B10のセルに文字など入力がするところがあります
入力はA1から順番に入れていきます

例えば
保存ボタンを作成しておく
シート1のA1に日付、B1に”文字”を入力し、保存ボタンをおす
情報シートに日付と内容が一致する情報がなければ、
情報シートのA列にシート名、B列に日付、C列に入力した内容が
空白のところに出力される

ボタンのマクロがCommandButton1_Clickとしたら
Private Sub CommandButton1_Click()
検索
End Sub

標準モジュールに

Sub 検索()
Dim c As Range
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim ws1LastRow As Long
Dim ws2LastRow As Long

Set ws1 = Sheets("情報シート")
Set ws2 = ActiveSheet

If ws2.Range("A1").Value = "" Or ws2.Range("B1").Value = "" Then
MsgBox "検索する日付もしくは語句が入力されていません。", vbCritical
Exit Sub
End If
If ws1.Range("A1").Value = "" Then
ws1LastRow = 0
Else
ws1LastRow = ws1.Cells(Rows.Count, "A").End(xlUp).Row
End If
ws2LastRow = ws2.Cells(Rows.Count, "A").End(xlUp).Row
For Each c In ws1.Range(ws1.Cells(1, "B"), ws1.Cells(Rows.Count, "B").End(xlUp))
If c.Value2 = ws2.Cells(ws2LastRow, "A").Value2 Then
If c.Offset(0, 1).Value = ws2.Cells(ws2LastRow, "B").Value Then
MsgBox "既にデータが存在します", vbInformation
Exit Sub
End If
End If
Next
ws1.Cells(ws1LastRow + 1, "A").Value = ws2.Name
ws1.Cells(ws1LastRow + 1, "B").Resize(1, 2).Value = ws2.Cells(ws2LastRow, "A").Resize(1, 2).Value
MsgBox "データを追加しました", vbInformation
Set ws1 = Nothing
Set ws2 = Nothing
End Sub

これを教えて頂き作っていたのですが
別のシートを作成しこのプログラムを応用していたのですが
うまく起動しないため再度投稿しました
今度のやつは固定でやろうと思っていていじったのですが
別の欄の文字が表示してしまった

結合セルB2:C4に日付を入れる
結合セルL2:L30に内容を入れるようにしたいのですが
ここだけのセルを参照するようにしたいのです。

どうすればいいでしょうか?
試したことAをB2にかえ、BをL2にしたら変なことになりました・・・

投稿日時 - 2016-09-17 10:37:18

QNo.9230313

困ってます

質問者が選んだベストアンサー

入力が固定でしたらボタンのついているシートの最終行を求めなくていいですし、入力位置も連続していないので、現状のコードのセル番地を変更するだけでは変になると思います。

以下のように変更してみてください。

Sub 検索()
Dim c As Range
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim ws1LastRow As Long

Set ws1 = Sheets("情報シート")
Set ws2 = ActiveSheet

If ws2.Range("B2").Value = "" Or ws2.Range("L2").Value = "" Then
MsgBox "検索する日付もしくは語句が入力されていません。", vbCritical
Exit Sub
End If
If ws1.Range("A1").Value = "" Then
ws1LastRow = 0
Else
ws1LastRow = ws1.Cells(Rows.Count, "A").End(xlUp).Row
End If
For Each c In ws1.Range(ws1.Cells(1, "B"), ws1.Cells(Rows.Count, "B").End(xlUp))
If c.Value2 = ws2.Cells(2, "B").Value2 Then
If c.Offset(0, 1).Value = ws2.Cells(2, "L").Value Then
MsgBox ws1.Name & " " & c.Row & "行目に既にデータが存在します", vbInformation
Exit Sub
End If
End If
Next
ws1.Cells(ws1LastRow + 1, "A").Value = ws2.Name
ws1.Cells(ws1LastRow + 1, "B").Value = ws2.Cells(2, "B").Value
ws1.Cells(ws1LastRow + 1, "C").Value = ws2.Cells(2, "L").Value
MsgBox "データを追加しました", vbInformation
Set ws1 = Nothing
Set ws2 = Nothing
End Sub

投稿日時 - 2016-09-17 11:45:33

お礼

毎回ありがとうございます
助かります

投稿日時 - 2016-09-17 12:01:39

ANo.1

このQ&Aは役に立ちましたか?

0人が「このQ&Aが役に立った」と投票しています

回答(1)

あなたにオススメの質問