- ベストアンサー
VBAで複数Excelの複数条件を満たすもの抽出
HohoPapaの回答
- HohoPapa
- ベストアンサー率65% (454/692)
他の方のコメントに同意であり、 さすがに厳しいデータ構成と思いますし、 ＤＢを使った仕組みが望ましいものの、 簡単に移行できるわけではないでしょう。 なので、現データ構成まま、若干泥臭いものの、 また、実用に耐えるかどうかはわかりませんが 若干効率のよさそうなコードを提示したいと思っています。 そこで、コーディングするにあたり、以下を教えてください。 ・1月顧客別商品別.xlsにはどの程度のレコード数がありますか？ ・顧客別管理.xlsxにはどの程度のシート数がありますか？ ・顧客コード、商品コードは数値ですか？、文字列ですか？ ・顧客別管理.xlsxのA9,B9以下とA39,B39以下には、 上詰めでコードと商品名が埋まっていますか？ それとも、空行が途中に含まれますか？
関連するQ&A
- VBA 複数のシートをまたいでの連想配列
win7、Excelは2013を使用しています。 添付画像の様に、12シートの合計を連想配列に格納しsheet13に書き出したいのですが、プロシージャーの下から6行目のところで、エラーコード451が出ます。 どの様に変更すれば良いか教えて下さい。 Sub 年間集計() Dim Dic Dim i As Integer Dim j As Integer Dim sh As Worksheet Dim rng As Range Dim buf As String Dim num As Integer Set Dic = CreateObject("Scripting.Dictionary") For Each sh In Worksheets For Each rng In sh.Range("J2", sh.Cells(Rows.Count, 10).End(xlUp)) buf = rng.Value num = rng.Offset(, 1).Value If Not Dic.Exists(buf) Then Dic.Add buf, num Else Dic.Item(buf) = Dic.Item(buf) + num End If Next rng Next sh j = 2 With Worksheets("Sheet13") For i = 0 To Dic.Count - 1 .Cells(j, 1) = Dic.Keys(i) ’エラー箇所 .Cells(j, 2) = Dic.Items(i) j = j + 1 Next i End With End Sub
- ベストアンサー
- Excel（エクセル）
- エクセルの複数条件抽出
エクセルで複数条件のカウントをしようと思い、下のマクロを作成しました。 うまくカウントができないのですが、どこらへんが間違っていますでしょうか？ （実際にはもっと多くのデータで利用を予定しており、小さいものでテストしています） よろしくお願いします。 Dim c1 As String Dim c2 As String Dim ans As Long Dim ws As Worksheet Dim b As Long, a As Long Set ws = Worksheets("date") For b = 2 To 4 For a = 3 To 5 c1 = Cells(a, 1).Value c2 = Cells(2, b).Value With ws.Range("B2:C7") ans = Evaluate("sumproduct((" & .Columns("c").Address & "=""" & c1 & """)*(" & .Columns("B").Address & "=""" & c2 & """))") Worksheets("a").Cells(a, b).Value = ans End With Next a Next b End Sub
- 締切済み
- オフィス系ソフト
- エクセルVBA VLOOKUPについて
エクセル VBA初心者です。 関数でのVLOOKUPをVBAで作りたいのですが、上手くいきません。 あらかじめ、Sheet2の1から300行までに A列 / B列 商品名 / 商品コード が入力されています。(名前の定義=商品コード) Sheet1にユーザーフォームを利用して、データを書き込んだ後、 B列に商品名が書き込まれると、 A列に商品コードが表示されるようにしたいと考えています。 A列に =IF(B2="","",VLOOKUP(B2,商品コード,2,FALSE)) と入力していたのですが、 VBAでIfを使って出来ないかと考えてみたのですが、 上手くいきませんでした。 Private Sub Worksheet_Change(ByVal Target As Range) Dim sRow As Long Dim sColumn As Long sRow = ActiveCell.Row sColumn = ActiveCell.Column If Cells(sRow, 2).Value = True Then Cells(sRow, 1).Value = WorksheetFunction.VLookup(Cells(sRow2).Value, Worksheets("Sheet2").Range("A1:B300"), 2, False) ElseIf Cells(sRow, 2).Value = " " Then Cells(sRow, 1).Value = " " End If End Sub ご教授いただけないでしょうか？ エクセル2003 WindowsXP
- ベストアンサー
- オフィス系ソフト
- VBA 抽出後、別シートにコピー
ＯＳはＸＰ、Ｅｘｃｅｌは２００３を使用しています。 下記は、元シートから新規シートにデータ全部をコピーする様に組んでいるのですが、これを利用して、Ａ列に「３」が入力されているデータのみを抽出して新規シートにコピーするしたいです。 Dim cellgyo As Long '［元シート］で注目している行 Dim kakikomigyo As Long '［新規シート］で書き込む Dim jigyosyocode As Variant '担当事業者コード Dim tantocode As Integer '担当者コード Dim tokuisakicode As Long '得意先コード Dim tokuisakiname As String '得意先名 Dim yomicode As String '読みコード Dim postcode As String '郵便番号 Dim add1 As String '住所１ Dim add2 As String '住所２ Dim telno As String '電話番号 Dim faxno As String 'FAX番号 kakikomigyo = 3 '［新規シート］に最初に書き始める行 For cellgyo = 2 To 63335 'Forループの始まり Sheets("元シート").Select '［元シート］シートを選択／Cells(行,列) ’**** jigyosyocode = Cells(cellgyo, 1).Value tantocode = Cells(cellgyo, 5).Value tokuisakicode = Cells(cellgyo, 2).Value tokuisakiname = Cells(cellgyo, 3).Value yomicode = Cells(cellgyo, 4).Value postcode = Cells(cellgyo, 16).Value add1 = Cells(cellgyo, 17).Value add2 = Cells(cellgyo, 18).Value telno = Cells(cellgyo, 19).Value faxno = Cells(cellgyo, 20).Value If jigyosyocode = "0" Then Exit For End If Sheets("新規シート").Select Cells(kakikomigyo, 1).Value = jigyosyocode 'Cells(行,列) Cells(kakikomigyo, 2).Value = tantocode Cells(kakikomigyo, 3).Value = tokuisakicode Cells(kakikomigyo, 4).Value = tokuisakiname Cells(kakikomigyo, 5).Value = yomicode Cells(kakikomigyo, 6).Value = postcode Cells(kakikomigyo, 7).Value = add1 Cells(kakikomigyo, 8).Value = add2 Cells(kakikomigyo, 9).Value = telno Cells(kakikomigyo, 10).Value = faxno kakikomigyo = kakikomigyo + 1 Next cellgyo ----------------------- ----------------------- データを抽出しようと思い、 Range("A1").Select Selection.AutoFilter Selection.AutoFilter Field:=1, Criteria1:="3" Selection.CurrentRegion.Copy を ****のところに挿入してみたのですが、 どうも上手く行きません。 説明の足りないところあるかと思いますが、 どなたか修正点教えて下さいますようお願いします。
- ベストアンサー
- その他MS Office製品
- ExcelのVBAについて(勉強中のです。)
ExcelのVBAについて(勉強中のです。) ここからコード3以降に入力したコードを抜き出してデータ表を作成しそれを保存するコードを作成したいです。例えばCSV形式にするとか？ データ表は1日分の表示で、保存して週間や月間または統計データまでを視野にいれています。今回は保存する所です。。 利用しやすい状態と保存形式で、よろしくお願いします。データは生活記録みたいなものです。何したどうしたどうなった？ ※大分分岐する予定で、作成中であり、今回はコードの整理は不要です。 '///Sheet1/// Private Sub Worksheet_Change(ByVal Target As Excel.Range) Dim time7 As Range For Each time7 In Target If time7.Column = 1 Then time7.Offset(0, 4).Value = Format(Now, "Short Time") & vbCrLf & _ Format(Now, "yyyy/mm/dd hh:nn:ss AM/PM") End If Application.EnableEvents = False Application.EnableEvents = True Next time7 '(1)シートを変数にセット Dim ws1 As Worksheet Dim ws2 As Worksheet Set ws1 = Worksheets("Sheet1") Set ws2 = Worksheets("Sheet2") '(2)シートを指定してデータを転記 ws2.Range("A3:H3").Value = ws1.Range("A3:H3 ").Value End Sub Private Sub Worksheet_Activate() ' ' 新規行挿入 ' ' Worksheets("Sheet2").Range("3:3").Insert Sheets("Sheet1").Range("H3").Select ActiveCell.FormulaR1C1 = "5" Sheets("Sheet1").Range("E3").Select Selection.ClearContents Dim str_Left As String 'セルE4に文字列、セルH4に数字を予め入れておくこと。 str_Left = Left(Cells(4, 5), Cells(4, 8)) MsgBox str_Left & vbCrLf & " " & "OKボタンを押してください!" Sheets("Sheet1").Range("A3").Select Dim se_r As String se_r = Application.InputBox("バーコードを入力してください") Select Case se_r Case "False" MsgBox "キャンセルされました" Case "" MsgBox "空欄が入力されました" Case Else Range("A3").Value = se_r End Select End Sub ' ///Sheet2/// Private Sub Worksheet_Activate() Dim Emp(1 To 300) As String Dim msg As String Dim i, i2, Cnt As Integer Dim N_In As Variant For i = 3 To 3 If IsEmpty(Cells(i, 1).Value) = False Then 'ここで空欄判定 Worksheets("Sheet1").Range("3:3").Insert '対象セルアドレスを改行処理 End If Next i '(1)シートを変数にセット Dim ws1 As Worksheet Dim ws2 As Worksheet Set ws1 = Worksheets("Sheet1") Set ws2 = Worksheets("Sheet2") ws1.Activate End Sub
- 締切済み
- その他（プログラミング・開発）
- エクセル2019 VBAについて
エクセル2019でVBAを使いコピーペーストの勉強中です、次の箇所(Dim i As integr)で、ユーザー定義型は定義されていませんと指摘されて止まってしまします、Sheet("データ")には3行のデータは入っています、VBA初心者のため、この後が、なかなか前に進めません、どうかよろしくおねがいします。 ********************************** Sub 練習() Dim s1 As Worksheet: Set s1 = Worksheets("請求書") Dim s2 As Worksheet: Set s2 = Worksheets("データ") Dim r1 As Integer: r1 = 18 Dim r2 As Integer: r2 = 2 { Dim i As integr } For i = 0 To 2 s1.Range(s1.Cells(r1 + i, 1), s1.Cells(r1 + i, 3)).Value = s2.Range(s2.Cells(r2 + i, 2), s2.Cells(r2 + i, 4)).Value s1.Cells(r1 + i, 4).Value = s1.sells(r1 + i, 2).Value * s1.Cells(r1 + i, 3).Value Next End Sub ***************************************
- ベストアンサー
- Excel（エクセル）
- エクセルVBAで
登録ボタンを作りたいのですが うまくいきません。 応答無しになってしまいます。 仕事でコードを入力して、住所やその他の関連事項を 登録して、検索し、封筒に宛名印刷し、登録内容の修正をしたいと思っています。 登録ボタンは下記のようなものを作りました。 Private Sub CommandButton1_Click() Dim bk As Workbook Dim sh1 As Worksheet Dim sh2 As Worksheet Dim cnt1 As Long Set bk = ThisWorkbook Set sh1 = bk.Worksheets("現場登録検索") Set sh2 = bk.Worksheets("一覧") cnt1 = 6 Do While sh2.Cells(cnt1, 2).Value <> "" cnt = cnt1 + 1 Loop '得意先CD sh2.Cells(cnt1, 2).Value = sh1.Cells(2, 3).Value '現場CD sh2.Cells(cnt1, 3).Value = sh1.Cells(3, 3).Value '送り方 sh2.Cells(cnt1, 22).Value = sh1.Cells(4, 3).Value '封筒 sh2.Cells(cnt1, 23).Value = sh1.Cells(5, 3).Value MsgBox "登録できました。" End Sub 何が悪いのでしょうか? よろしくお願い致します。
- ベストアンサー
- その他（プログラミング・開発）
- VBAで教えて下さい。
VBA初心者です。始めてから２，３週間です。 表を作りたいのですが、 顧客名のシートを１００枚ほど作り、シート１（シート１は検索シートにしたいので顧客名は無）のA1にクライアント名を入力したら入力した顧客名シートが出てくる様にしたいです。 参考書、ネット等をみて作成しましたがエラーが出ます。作動するにはどの様にしたら宜しいでしょうか？どうかお助け下さい。宜しくお願い致します。コードは下記です。 Private Sub Worksheet_Change(ByVal Target As Range) Dim i As Integer Dim myWSname As String, myworksheet As Worksheet myWSname = "i" myWSname = Worksheets("sheet2").Range("A1").Value For Each myworksheet In Worksheets If myworksheet.Name = mayWSname Then Worksheets("myWSname").Activate Exit Sub End If Next myworksheet End Sub
- ベストアンサー
- Visual Basic
- Excel VBA 配列による複数セルへの入力
VBA初心者です．よろしくお願いいたします． 用語の読みを自動で振るシートを作成しているのですが，Do Loop部分が一行ずつの入力となっていて，時間がかかっています． これを配列等の方法を用いて高速化したいと思って，試行錯誤したのですが，うまくいきません． 何卒お教えくださいますようお願いいたします． 用語の読みを生成する手順ですが， １．シート1に用語をペーストする ２．ペーストされた用語をシート２にある用語のDB（用語と読みが入力されています．重複レコードなし）にコピー ３．コピーされたシート２をピボットにして個数が２以上あった場合，その用語と読みを返します． ４．Do Loopで最初にヒットした用語に戻るまでループ となっています． ３までの手順に修正の必要はないのですが，４の手順でかなり時間をロスしております． ここを配列等の方法で一度に書き込むことができればと思っています． Sub test() i = 8 L_Row04 = 180188 Dim S1 As Worksheet '読みを振る用語をペーストするシート Dim S2 As Worksheet '読み用の用語のDB Dim S3 As Worksheet 'ピボット Dim L_Row01 As Long 'S1にペーストされた用語の最下行 Dim L_Row02 As Long 'S1の用語をs2にペーストしたときの最下行 Dim L_Row03 As Long 'ピボットの用語の最下行 Dim Rng01 As Range 'S1にペーストされた用語の範囲 Dim Rng02 As Range 'S2にペーストされた用語の範囲 Dim Rng03 As Range 'ピボットの範囲 Dim Str01 As Variant 'ピボットで2以上あったときの用語 Dim Str02 As Variant 'ピボットで2以上あったときの読み Dim firstcell As Range Dim Foundcell01 As Range Set S1 = Worksheets(1) Set S2 = Worksheets(2) Set S3 = Worksheets(3) S1.Activate L_Row01 = S1.Cells(Rows.Count, 2).End(xlUp).Row L_Row02 = S2.Cells(Rows.Count, 3).End(xlUp).Row Set Rng01 = S1.Range(Cells(i, 2), Cells(L_Row01, 2)) Rng01.Copy Destination:=S2.Cells(L_Row02 + 1, 2 + 1) S3.PivotTables("ピボットテーブル2").RefreshTable S2.Activate L_Row02 = S2.Cells(Rows.Count, 3).End(xlUp).Row Set Rng02 = S2.Range(Cells(L_Row04, 3), Cells(L_Row02, 3)) Rng02.Delete S3.Activate L_Row03 = S3.Cells(Rows.Count, 2).End(xlUp).Row Set Rng03 = S3.Range(Cells(4, 2), Cells(L_Row03, 2)) For Each a In Rng03 If a >= 2 And a.Offset(0, -1).Value <> "(空白)" And a.Offset(1, -1).Value <> "(空白)" Then Str01 = a.Offset(0, -1) Str02 = a.Offset(1, -1) S1.Activate Set Foundcell01 = Rng01.Find(What:=Str01, searchorder:=xlByRows, LookIn:=xlValues, lookat:=xlWhole) Do Selection.Offset(0, 1).Value = Str02 Selection.Offset(0, 2).Value = "●" Loop Until ActiveCell.Address = firstcell.Address End If End If Next End Sub
- ベストアンサー
- Visual Basic
- VBAで実行時エラー1004が出ます
VBAで実行時エラー1004が出ます。 「Rangeメソッドは失敗しました。Worksheetオブジェクト」です。 あらゆる可能性を調べたのですが、分かりません。誰か教えて頂けますでしょうか？ 下記コードの「Cells(m, 7) =・・・」の部分がエラーになりました。 Sub ボタン1_Click() Dim 現シート As Worksheet ～ 現シート.Activate Cells(m, 7) = WorksheetFunction.VLookup(現シート.Range(現シート.Cells(m, 4)).Select, 現シート.Range(現シート.Cells(4, 104), 現シート.Cells(15, 107)).Select, 4, False) ～ End Sub 何卒宜しくお願いいたします。
- 締切済み
- Excel（エクセル）