みんなの「教えて(疑問・質問)」にみんなで「答える」Q&Aコミュニティ

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

解決済みの質問

Match関数がうまく機能していない??

すみません。また教えて下さい。
過去ログを見てシート1にあったデータをシート4にあるデータと照らし合わせてすでにあれば書き換え、なければ追加というようにできるようにしたく過去ログを参考にしてやったのですが、どうしてもエラーが出てしまいます。
Private Sub aa()
Dim intlastrow1 As Integer
Dim strb As String
Dim longlastrow1 As Long
intlastrow1 = Sheets(1).Range("A7").End(xlDown).Row
longlastrow1 = Sheets(4).Range("A1").End(xlDown).Row
Dim c As Object
Dim rtn As Variant
Dim d As Integer
With Sheets(4)
.Select
For Each c In .Range("A1", "A" & longlastrow1)
rtn = Application.Match(c.Value, Sheets(1).Range("A7:A" & intlastrow1), 0)
d = c.Row
strb = Cells(d, "A").Value
If IsError(rtn) Then
With Sheets(4).Cells(longlastrow1 + 1, "A")
.Value = strb
With .Font
.Name = "MS Pゴシック"
.Bold = False
.Size = 8
End With
End With
Sheets(4).Cells(longlastrow1 + 1, "B").Value = Sheets(1).Range("A2").Value
Sheets(4).Cells(longlastrow1 + 1, "F").Value = ShowFormula(Sheet1.Range(Cells(d, "J"), Cells(d, "N")))
longlastrow1 = longlastrow1 + 1
End If
If Not IsError(rtn) Then
Exit Sub
End If
Next c
End With
End Sub

以上のように組んだのですがうまくいきません。
具体的に言うとシート1のA7よりしたに名前が並んでいる(山田、鈴木・・・)とお考え下さい(シート4のA2以下にも同様に名前が並んでいる)。字数の関係で判定後の処理が不十分になっています。

投稿日時 - 2005-06-05 21:50:30

QNo.1431372

すぐに回答ほしいです

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

#1です。

#2がイメージに近いものなら、#2よりはこの方が良いかも。

Sub Test1()
Dim tR As Range, fR As Range, fRow
Dim tW As Worksheet, fW As Worksheet

Set tW = Worksheets(4)
Set fW = Worksheets(1)
Set tR = tW.Range("A1", tW.Range("A65536").End(xlUp))

 For Each fR In fW.Range("A7", fW.Range("A65536").End(xlUp))
  fRow = Application.Match(fR, tR, 0)
   If IsError(fRow) Then
     tW.Range("A65536").End(xlUp).Offset(1, 1) = fR.Offset(0, 1)
     tW.Range("A65536").End(xlUp).Offset(1, 0) = fR
   Else
     tW.Range("B" & fRow) = fR.Offset(0, 1)
   End If
 Next fR

End Sub

投稿日時 - 2005-06-06 00:57:40

お礼

なぜだか私にはよく分かりませんが、こちらの方を試してみるとバッチリうまくいきました。本当にどうもありがとうございます。

投稿日時 - 2005-06-06 01:07:06

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

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

回答(3)

ANo.2

#1です。

> 私の本来したいこととはまるで違います

最初に提示されたコードは、私が読んだ限りではその「まるで違う」内容に思えますよ。

↓これは Sheets(4).Range("A1:Axxx") をループしてますので、最初の c はSheets(4).Range("A1")です。
For Each c In .Range("A1", "A" & longlastrow1)
  ↓これは上記の c をSheets(1).Range("A7:Axx")から探してます。
  rtn = Application.Match(c.Value, Sheets(1).Range("A7:A" & intlastrow1), 0)


こんな感じかな?

Sub Test()
Dim tR As Range, fR As Range, fRow
Dim tW As Worksheet, fW As Worksheet

Set tW = Worksheets(4)
Set fW = Worksheets(1)
Set tR = tW.Range("A2", tW.Range("A1").End(xlDown))

 For Each fR In fW.Range("A7", fW.Range("A7").End(xlDown))
  fRow = Application.Match(fR, tR, 0)
   If IsError(fRow) Then
     tW.Range("A1").End(xlDown).Offset(1, 1) = fR.Offset(0, 1)
     tW.Range("A1").End(xlDown).Offset(1, 0) = fR
   Else
     tW.Range("B" & fRow + 1) = fR.Offset(0, 1)
   End If
 Next fR

End Sub

投稿日時 - 2005-06-06 00:44:05

補足

実行してみたのですが、「アプリケーション定義またはオブジェクト定義のエラーです。」とでて、うまくいきません。デバッグをクリックすると「 tW.Range("A1").End(xlDown).Offset(1, 1) = fR.Offset(0, 1)」の部分が黄色くなるのですが・・・。
ちなみに、「私の本来したいこととはまるで違います」の部分は「処理を抜け出す」という部分は本当は違うように処理するようにコードを書いたのに字数の関係で投稿できないので致し方なくこのようなコードに書き換えて投稿した、という意味であって決してpapayukaさんが書いて下さった事自体に対する反応ではないことご了解下さい。

投稿日時 - 2005-06-06 00:57:35

ANo.1

仕様がよく見えません。
ソースを読めではなく、具体的な仕様を書かれては?

まず、Sheet(4).Range("A1")の値を Sheet(1).Range("A7:Axxx") 内で探して、
見つからなかったら、『Sheet(4).Range("A1")の値を Sheet(4)のA列最後に追加』して、
見つかったら『全ての処理をやめてSub を抜ける』という仕様ですか?

投稿日時 - 2005-06-05 22:58:19

補足

やっぱりソースだと字数の関係もあってダメですね。
今度から仕様を書くことにします。(といっても説明しづらいのですが・・・。)
基本的にsheets(1)のA7以下のA列に何行か(場合によります)名前が書かれておりその列の行にはデータが並んでいて、これらをsheets(4)に名前がなければ新たに最後の列に追加する。名前があればその列の行のデータを自分で設定する条件に合わせて(IFを使うなどして)データを上書きなどの処理をしたいのです。ちなみにsheets(4)、sheets(1)ともに同一の名前が重複することはありません。
上記の回答にあわせて言えばまず、Sheet(1).Range("A7")の値を Sheet(4).Range("A2:Axxx") 内で探して、見つからなかったら、『Sheet(1).Range("A7")の値を Sheet(4)のA列最後に追加』する。(次はSheet(1).Range("A8")の値を・・・)というようにしたいのです。見つかったら『全ての処理をやめてSub を抜ける』というところは質問が長すぎると言うことなのでとりあえず形になるもの・・という意味で書きました。私の本来したいこととはまるで違います。

投稿日時 - 2005-06-05 23:21:09

あなたにオススメの質問