- ベストアンサー
行列で検索をかけてその結果を転記するVBAは
早速ですが質問させていただきます。 sheet1のA列に月日、2行目に製品名をとり製品個数を記した表があります。(列数150行数1000です)これをsheet3のCells(2, 6)に記入した月日とCells(2, 4)に記入した製品名(文字)の2つでsheet1の行と列から当てはまるセルの検索をコマンドボタンを押すことにより行い、そのセルにsheet3のCells(2, 7)に記入した製品個数を転記するようなVBAを書きました。 Private Sub CommandButton1_Click() Dim LastA, idxA As Long, trgA, trgB With Worksheets("Sheet3") LastA = .Range("A1000").End(xlUp).Row trgA = Application.Match(.Cells(2, 6), Worksheets("Sheet1").Range("A:A"), 0) For idxA = LastA To 3 Step -1 trgB = Application.Match(.Cells(2, 4), Worksheets("Sheet1").Range("2:2"), 0) Worksheets("Sheet1").Cells(trgA, trgB) = .Cells(2, 7) Next idxA End With End Sub 以前質問して教えていただいたものを参考に、少し変更してみたのですがこれで正しいでしょうか?実行するとうまく転記するのですがかなり時間がかかってしまい、もう少し何とかならないものかと思っています。どなたかご指導お願いします。
- ss003
- お礼率50% (2/4)
- オフィス系ソフト
- 回答数2
- ありがとう数2
- みんなの回答 (2)
- 専門家の回答
質問者が選んだベストアンサー
こんばんは。 元のコードは、まったく無意味な部分があるような気がしますね。 以下のようなコードはいかがでしょうか? このコードは、古いスタイル雰囲気があります。 かならず、エラー処理はつけたほうがよいです。 .Cells(2, 6).Value2 としてありますので、書式に違いには影響を受けません。 Private Sub CommandButton1_Click() Dim trgA As Variant, trgB As Variant With Worksheets("Sheet3") If IsEmpty(.Cells(2, 7)) Then MsgBox "個数が空です。", vbCritical: Exit Sub '日付 trgA = Application.Match(.Cells(2, 6).Value2, Worksheets("Sheet1").Range("A:A"), 0) If IsError(trgA) Then MsgBox "該当する日付がありません。", vbCritical: Exit Sub '製品名 trgB = Application.Match(.Cells(2, 4).Value, Worksheets("Sheet1").Range("2:2"), 0) If IsError(trgB) Then MsgBox "該当する製品名がありません。", vbCritical: Exit Sub If Worksheets("Sheet1").Cells(trgA, trgB).Value = "" Then Worksheets("Sheet1").Cells(trgA, trgB).Value = .Cells(2, 7).Value Else If MsgBox("上書きしますか", vbQuestion + vbOKCancel) = vbOK Then Worksheets("Sheet1").Cells(trgA, trgB).Value = .Cells(2, 7).Value End If End If End With End Sub
その他の回答 (1)
- papayuka
- ベストアンサー率45% (1388/3066)
LastA と idxA のループは使われてないような、、、 あまり変わらないような気もしますが、※の1~3を消すと早くなりますか? あと、対象シートは計算式がいっぱいのシートですか? With Worksheets("Sheet3") LastA = .Range("A1000").End(xlUp).Row '※1 trgA = Application.Match(.Cells(2, 6), Worksheets("Sheet1").Range("A:A"), 0) For idxA = LastA To 3 Step -1 '※2 trgB = Application.Match(.Cells(2, 4), Worksheets("Sheet1").Range("2:2"), 0) Worksheets("Sheet1").Cells(trgA, trgB) = .Cells(2, 7) Next idxA '※3 End With
お礼
早速、回答いただき有難うございました。 仰るとおり※は必要なかったです。消去しましたら早くなりました。 依然教えていただいた時の解釈が間違っていました。Cells(2, 6)の値とMatchするものをRange("A1000")からひとつずつ上にチェックするんだなと思っておりました。ぜんぜん必要なかったなんて・・ばかですねー。 助かりました、本当に有難うございました。
関連するQ&A
- 【VBA】 超初心者です 複数のシートに転記したい
Sub べんきょう() Worksheets(Array(1, 3)).Select Range("A1").value = 20 End Sub もしくは Sub べんきょう() Worksheets("sheet1").Select Worksheets("sheet3").Select False Range("A1").value = 20 End Sub でやってもsheet1にしか転記されないんです!! ご指導よろしくお願いします!
- 締切済み
- オフィス系ソフト
- DTPickerで入力したらの検索が出来なくなりました。
お世話になります。 質問ですが 以下のVBAコードがあります。Sheet3のCells(2, 6)に記入した日付によってSheet1の検索を一部行うのですが、Cells(2, 6)への入力をDTPickerを使って行うようにしたら該当する日付がありませんのエラーが帰ってきます。たぶん書式が違うせいかなと思うのですがどうすればいいのでしょうか? どなたか分かる方いらっしゃいますか?よろしくお願いします。 Private Sub CommandButton1_Click() Dim trgA As Variant, trgB As Variant With Worksheets("Sheet3") If IsEmpty(.Cells(2, 7)) Then MsgBox "個数が空です。", vbCritical: Exit Sub '日付 trgA = Application.Match(.Cells(2, 6).Value2, Worksheets("Sheet1").Range("A:A"), 0) If IsError(trgA) Then MsgBox "該当する日付がありません。", vbCritical: Exit Sub '製品名 trgB = Application.Match(.Cells(2, 4).Value, Worksheets("Sheet1").Range("2:2"), 0) If IsError(trgB) Then MsgBox "該当する製品名がありません。", vbCritical: Exit Sub If Worksheets("Sheet1").Cells(trgA, trgB + 1).Value = "" Then Worksheets("Sheet1").Cells(trgA, trgB + 1).Value = .Cells(2, 7).Value Else If MsgBox("上書きしますか", vbQuestion + vbOKCancel) = vbOK Then Worksheets("Sheet1").Cells(trgA, trgB + 1).Value = .Cells(2, 7).Value End If End If End With End Sub
- 締切済み
- オフィス系ソフト
- VBA転記について教えて下さい
200件位のデータがあるとします。顧客情報AB・商品C~AY 氏名 性 青森りんご 長野りんご みかん バナナ 送料 AA 男 1 2 100 BB 女 1 100 CC 男 3 0 このデータを別シートAにはりんごと送料 別シートBにはそれ以外のデータに分けたいのです。 シートA 氏名 性 青森りんご 長野りんご 送料 AA 男 1 100 BB 女 1 100 CC 男 シートB 氏名 性 みかん バナナ AA 男 2 BB 女 CC 男 3 こんな感じです。 色々参考にして作成しましたがうまくいきませんでしたので 教えて欲しいです。 よろしくお願いします。 エクセルは2002です。 1、項目名の転記でデータは200位ですが変動があるので最終行で作成したら うまくいきませんでした。 2、データ域の転記が動きません。 Sub サンプル() Dim i As Long Dim lastRow As Long Dim lastcolumns As Long Dim S1 As Worksheet, S2 As Worksheet, S3 As Worksheet Dim myColumns As Long Dim myKey As String Set S1 = Worksheets("データ") Set S2 = Worksheets("りんご") Set S3 = Worksheets("その他") ' Sheet1の最終行を取得 lastRow = S1.Range("A" & Rows.Count).End(xlUp).Row ' Sheet1の最終列を取得 lastcolumns = S1.Cells(1, Columns.Count).End(xlToLeft).Column ' 項目名の転記 S2.Range("A1:B200").Value = _ S1.Range("A1:B200").Value S3.Range("A1:B200").Value = _ S1.Range("A1:B200").Value 'データ域の転記 For i = 2 To lastcolumns myKey = S1.Cells(1 & i).Value If myKey <> "" Then myColumns = Worksheets(myKey).Cells(1, Columns.Count).End(xlUp).Columns + 1 S1.Range(S1.Cells(1, i), S1.Cells(lastRow, i)).Copy _ Worksheets(myKey).Range(Cells(1, myColumns), Cells(lastRow, myColumns)) End If Next i End Sub
- ベストアンサー
- Excel(エクセル)
- エクセルVBAの転記について
エクセル2013VBAで最終行を取得しての転記が上手くいきません。どのようにすれば良いかご教授ください。 簡単なサンプルを下記します。 Sub サンプル入力からのDBへの転記() Dim Sh1 As Worksheet Dim Sh2 As Worksheet Dim myRow As Long Set Sh1 = Worksheets("サンプル入力") Set Sh2 = Worksheets("サンプルDB") With Sh2 myRow = Range("A" & Rows.Count).End(xlUp).Row + 1 .Range("A" & myRow).Value = Sh1.Range("D4").Value .Range("B" & myRow).Value = Sh1.Range("F4").Value End With End Sub 入力内容を変えないテストでは (1)実行するとDBへの転記は問題なく出来ます。 (2)継続してマクロを実行しても問題なく転記が行われ、同じデータが蓄積されていきます。 入力内容を変更して引き続きマクロを実行すると挙動不審に陥ります。 現象としては (1)初めの行に何度も重ねて転記を行う。 (2)空白行を作り、その行に何度も転記を行ってしまう。 (3)空白行を作り、それ以降転記を実行し蓄積を行ってしまう。 入力シートには結合セル、リストを使用していますが、原因究明を行う中でこれが原因とは思えませんでした。 これがクリアできないと先に進めません。ぜひお力を貸してください。 宜しくお願い申し上げます。
- ベストアンサー
- Windows 8
- 既存のVBAコードにエラー処理の追加をしたいのですが
たびたび申し訳ないです。 エクセル2003ですが、シート2のデータをシート1のA列にある日付と1行目にある製品名とで検索をかけて当てはまるセルにシート2のデータを転記する(下記記載)コードがあります。当てはまるセルがないときはシート2の対応するセルが赤く反転するエラー処理がなされています。 以前こちらで教えていただいたのですが、このコードに更に下記のようにシート1の当てはまるセルが入力済みならば上書きしますかと言う Worksheets("Sheet1").Cells(trgR, trgC) <>""Then If MsgBox("上書きしますか", vbQuestion + vbOKCancel) = vbOK Then Worksheets("Sheet1").Cells(trgR, trgC) = .Cells(idxR, 3) このようなコードをさらに付け加えたいのですが、どのようにすればいいかご教授願います。1週間いろいろやってみたのですがうまくいきません。赤く反転するエラー処理もそのまま生かしておきたいのです。長い質問で申し訳ありませんがよろしくお願いいたします。 元のコードです。 Private Sub CommandButton1_Click() Dim LastR, idxR As Long, trgR, trgC With Worksheets("Sheet2") LastR = .Range("A65536").End(xlUp).Row trgR = Application.Match(.Cells(1, 1), Worksheets("Sheet1").Range("A:A"), 0) For idxR = LastR To 3 Step -1 trgC = Application.Match(.Cells(idxR, 1), Worksheets("Sheet1").Range("1:1"), 0) If IsNumeric(trgR) And IsNumeric(trgC) Then Worksheets("Sheet1").Cells(trgR, trgC) = .Cells(idxR, 3) Else .Cells(idxR, 1).Interior.ColorIndex = 3 End If Next idxR End With End Sub
- 締切済み
- オフィス系ソフト
- VBA Match関数の使い方について
お世話になります ご教示頂けたら幸いです シート結果セルE4の値を検索してシート結果G4の値を 検索行のB列に値を転記したいです 下記のように書くとMatch関数行でエラーが出てしまいます どの様にすればいいのでしょうか? お手数おかけしますが 何卒よろしくお願いいたします With Sheets(Worksheets("結果").Range("A4").Value) WorksheetFunction.Match(Worksheets("結果").Range("E4").Value, Range("A1:A1000"), 0).Offset(3) = _ Worksheets("結果").Range("A4").Offset(2).Value End With
- 締切済み
- Excel(エクセル)
- 転記したデータを基にして検索表示させる方法
下記のようにシートAのデータをシートB(A列)へ転記した後に、転記したデータを基にしてデータベースから検索した結果をシートB(B列)に表示したいのですが、マクロを実行すると「型が一致しません」というエラーになります。 どのようにしたらエラーにならないのか… どうぞよろしくお願いします。 Sub レコード転記() Dim myTbl As Range, sakiRng As Range Set myTbl = Sheets("A").Range("B6:B81") Set sakiRng = Sheets("B").Range("A5") myTbl.Copy sakiRng.PasteSpecial xlPasteAll sakiRng.PasteSpecial xlPasteColumnWidths End Sub Private Sub Worksheet_Change(ByVal Target As Excel.Range) Dim r As Variant, myRange As Range Set myRange = Workbooks("入力フォーム.xls").Worksheets("一覧表").Range("社名") With Target If Target.Column = 1 Then r = Application.WorksheetFunction _ .Match(Target.Value, myRange, 0) Cells(Target.Row, 2) = Workbooks("入力フォーム.xls").Worksheets("一覧表").Range("N1").Offset(r - 1).Value End If End With End Sub
- ベストアンサー
- Visual Basic
- Excel マクロ 値の転記
Excel マクロ 値の転記 Sheet2をSheet1に転記したいのですが、A列だけは3回同じ値を転記 するのには、※をどのように変えたらいいのでしょうか? 宜しくお願い致します。 〔Sheet1〕転記先 A B あ 10 あ 20 あ 30 い 40 い 50 〔Sheet2〕転記元 A B あ 10 い 20 う 30 え 40 お 50 Sub テスト() Dim i As Long For i = 1 To 30 '↓※ココをどう書いて良いのかが分かりません Worksheets("Sheet1").Cells(i, "A") = Worksheets("Sheet2").Cells(i, "A") Worksheets("Sheet1").Cells(i, "B") = Worksheets("Sheet2").Cells(i, "B") Next i End Sub
- ベストアンサー
- その他MS Office製品
- VBA チェンジイベント 別シートにデータ転記
お世話になります。チェンジイベント初心者です。 同一BOOK内の特定のコラムのセルを選択した場合に、自動的に他のシートの特定のセルにデータを転記させたいのですが、どう書けばよいのか分かりません。添付の画像と下記マクロをご覧になって下さい。 -マクロ- Private Sub Worksheet_SelectionChange(ByVal Target As Range) If 1 = ActiveCell.Column Then Worksheets("01").Cells(ActiveCell.Row, 3) = Cells(ActiveCell.Row, 1) Worksheets("01").Cells(ActiveCell.Row, 4) = Cells(ActiveCell.Row, 2) End If End Sub メインのシートは[01]です。このシートのC4を選択し、次に[02]のA列にあるセルを選択すると、[02]のA列・B列のデータがC4・D5に転記されるようにしたいのですが、画像にあります通り[02]のA5を選択してしまうと、[01]のC5・D5に転記されてしまいます。 どのようにすれば、[01]でアクティブにしておいた行の3列目、4列目に転記が行われるのでしょうか? よろしくご指南くださいませ。
- 締切済み
- その他MS Office製品
- マクロで別シートの検索と別シートへの転記
windows7、エクセル2013です。 Sheet1のA列の値を上から順に、Sheet2のA列内を検索し 同じ値が有ればその値を Sheet3のB列の5行目から順番に転記したいです。 Findを使ってうまくできないので Countifを使いましたが、駄目でした。 関数で可能なら関数でもいいのですが、教えていただきたいです。 よろしくお願いします。 Sub 抽出転記() Dim 検索行 Dim 検索値 Dim 答 Dim 入力行 入力行 = 5 For 検索行 = 3 To 200 検査値 = Worksheets("Sheet1").Cells(検索行, 1) If Worksheets("Sheet2").Columns("A").CountIf(検索値) <> 0 Then 答 = 検索値 Worksheets("Sheet3").Cells(入力行, 2) = 答 入力行 = 入力行 + 1 End If Next 検索行 End Sub
- ベストアンサー
- Excel(エクセル)
お礼
早速、回答いただき有難うございました。 ↓にも書きましたが必要ない部分がありました。消すことによってうまくいきましたが、Wendy02さんのコードを採用させていただきます。エラー処理は全然頭になかったので・・・。新しく作っていただき感謝しております。 みなさん本当に有難うございました。