Excel VBAで工事台帳に金額を記述する方法

前へ 次へ
このQ&Aのポイント
  • Excel VBAを使用して、工事元帳複写シートのＬ列の金額を工事台帳に記述する方法について説明します。
  • 工事元帳複写のF列の値が工事台帳のＥ１に一致する場合、工事台帳のＣ１４からＯ１４までのコードが工事元帳複写のＡＣ列の値と一致したら日付等を工事台帳に記述します。
  • Excel VBAコードを使用して工事元帳複写シートの金額を工事台帳に記録する手順を示します。
回答を見る
  • ベストアンサー

２つの条件が一致した場合です

下記のコードは、工事元帳複写シートのＬ列の金額を工事台帳に記述するものです。 Sub 工事台帳記述() Dim iRow As Long Dim FoundCell1 As Variant, FoundCell2 As Variant Dim MySheet1 As Worksheet, MySheet2 As Worksheet Set MySheet1 = Worksheets("工事台帳") Set MySheet2 = Worksheets("工事元帳複写") Set FoundCell1 = MySheet2.Range("F:F").Find(what:=MySheet1.Range("E1").Value, LookIn:=xlValues, LookAt:=xlWhole) ＜工事元帳複写のF列の値が工事台帳のＥ１に一致＞ Set FoundCell2 = MySheet1.Range("C14:O14").Find(what:=FoundCell1.Offset(0, 23).Value, LookIn:=xlValues, LookAt:=xlWhole) ＜工事台帳のＣ１４からＯ１４までのコードが工事元帳複写のＡＣ列の 値と一致したら日付等を工事台帳に以下のコードで記述＞ iRow = MySheet1.Range("a10000").End(xlUp).Row + 1 MySheet1.Cells(iRow, 1).Value = FoundCell1.Offset(0, -4).Value MySheet1.Cells(iRow, 1).NumberFormatLocal = "m月d日" MySheet1.Cells(iRow, 2).Value = FoundCell1.Offset(0, 20).Value MySheet1.Cells(iRow + 1, 2).Value = FoundCell1.Offset(0, 21).Value FoundCell2.Offset(iRow - 14, 0).Value = FoundCell1.Offset(0, 6).Value End Sub このコードではＦ列の値が同一の場合には一つしか記述しません。 上記で記述した下の行につづけて表示したいのです。 ご指導お願いします

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

  • ベストアンサー
  • myRange
  • ベストアンサー率71% (339/472)
回答No.1

Findメソッドのヘルプを見ましたか？ 検査値が複数ヒットする場合のコードもちゃんと載ってます。 質問者のレベルならそれを見れば簡単に理解できると思いますが。 もし、それでも分からなければ再質問 と、いうことでどうでしょう。 それから、再質問するときは次のことも提示するべきでしょう。 　 提示のコードでは、２つのFindメソッドとも 検査値がヒットしない場合の処理がないが これは故意に省いているのか？ 　

miyama2305
質問者

お礼

ありがとうございました

  1. カテゴリ
  2. [技術者向] コンピューター
  3. プログラミング・開発
  4. Visual Basic

関連するQ&A

  • FIND関数について教えてください

    EXCEL VBAを使って、検索ツールを作成中です。 １，sheet1のセルA1に入力されたものをsheet2,3の特定の列から検索して、結果のすべてをsheet1 A2以下に表示する。 2,１の検索結果（A2以下）をそれぞれsheet2,3から更に検索する。 　※sheet2,3のA列からsheet1A1を検索し、同じ行のC,D列のデータをsheet1A2以下に持ってくる 　※A2以下の検索結果は複数。sheet2,3のA列からsheet1A2以下を検索し、C列から横に更なる検索結果があればそれを表示して行きたい。 まず書いたのは下記のようなもの Sub 検索() Dim FoundCell As Range, FirstCell As Range Set FoundCell = Cells("A:A") .Find(What:=sh1.range("A1").value) If FoundCell Is Nothing Then MsgBox "見つかりません" Exit Sub Else Set FirstCell = FoundCell FoundCell.Resize(1, 2).Copy Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0) End If Do Set FoundCell = Cells.FindNext(FoundCell) If FoundCell.Address = FirstCell.Address Then Exit Do Else FoundCell.Resize(1, 2).Copy Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0) End If Loop End Sub 検索1（）として If FoundCell Is Nothing Then MsgBox "見つかりません" Exit Sub を、 If FoundCell Is Nothing Then 検索2 と表記を変えて実行したのですが、見つからなかった場合、「見つかりません」のメッセージと共に「実行エラー5」で「 Set FoundCell = Cells.FindNext(FoundCell)」が示されます。 また、A2以下という曖昧な検索セルを指定する方法が分かりません。 　set str=sheet1.Cells(i,1).value というようなこともしてみたのですが、エラーになってしまいました。 なにかアイディアを教えてください。

  • Find関数内にFind関数をかける場合

    エラー91が発生し、手詰まりです。 どなたかご教授お願いいたします。 Find関数でDo～lppoを行い、初期の検索結果アドレスでLoopを抜けようと思ったのですが。。 エラーしてしまいました。 Find関数内にFind関数を用いることが出来ない と目にしたのですが。 下記のようなVBAの場合 どのように対処したらいいでしょうか？ また、VBA初心者のため VBA文が見づらかったり、おかしなところがあると思います。 その部分についても教えて頂けたらと思います。 Sub SAMPLE() Dim TargetDE As String '文字列型 Dim TargetNo As String '文字列型 Dim PODate As String '文字列型 Dim FoundCell As Range ' Dim FoundDate As Range Dim FoundCellNo As Long '長整数型 Dim FoundDateNo As String Dim SearchArea As Object 'オブジェクト型 Dim tar_obj(1) As Object 'オブジェクト型 Dim Addr As String '文字列型 Dim Lastrom As Long ' Dim POLEFT As Range '検索文字列入力（DE) TargetDE = Application.InputBox("Fill in a DE:??", "DE:??", Type:=2) If TargetDE = "False" Then Exit Sub '検索対象範囲 Set SearchArea = Workbooks("Sample sample.xlsx").Sheets("Sample") Set tar_obj(1) = Workbooks("INPUT FORMAT.csv").Sheets("INPUT FORMAT") '表示先をクリア tar_obj(1).Cells(1, 1).CurrentRegion.ClearContents '検索実行 Set FoundCell = SearchArea.Range("C:C").Find(What:=TargetDE, LookIn:=xlValues, _ LookAt:=xlPart, MatchCase:=False, MatchByte:=False) '検索文字列(DE)を含むセルがない場合は終了 If FoundCell Is Nothing Then Exit Sub '検索文字列入力（DE Number) TargetNo = Application.InputBox("Fill in DE nomber", "Nomber", Type:=2) If TargetNo = "False" Then Exit Sub '最初の検索結果の行数を格納 Addr = FoundCell.Address '検索文字列入力（PO Date) PODate = Application.InputBox("Fill in Sample Date", "Date", Type:=2) If PODate = "False" Then Exit Sub Do '検索Cell右横の値がTargetNoと同じ場合 If FoundCell.Offset(0, 1).Value = TargetNo Then '行番号を代入 FoundCellNo = FoundCell.Row '検索の下限値を変数に代入 F_LAST = FoundCellNo + 50 '検索実行 Set FoundDate = SearchArea.Range(SearchArea.Cells(FoundCellNo, 1), SearchArea.Cells(F_LAST, 1)).Find(What:=PODate, LookIn:=xlValues, _ LookAt:=xlPart, MatchCase:=False, MatchByte:=False) '検索文字列を含むセルがない場合は終了 If FoundDate Is Nothing Then 'MsgBox "Find is mistake" '検索文字列を含むセルがある場合 Else '変数に行番号代入 FoundDateNo = FoundDate.Row If FoundDate.Offset(1, 1).Value = "" Then MsgBox "The position of the cell is not correct. Please coordinate macro. " Else POLEFT = FoundDate.Offset(1, 1) For i = 2 To 13 If FoundDate.Offset(1, i) <> 0 Then If FoundDate.Offset(1, i) <> "." Then If IsNumeric(FoundDate.Offset(1, i).Value) = True Then '表示先(INPUT FORMAT)の行数をカウントアップ cnt = cnt + 1 PORIGHT = FoundDate.Offset(1, i).Value tar_obj(1).Range("E" & cnt) = POLEFT & PORIGHT End If End If End If Next i End If End If ElseIf FoundCell.Offset(0, 1) <> TargetNo Then ' MsgBox "Find is mistake" End If '次の検索を実行 Set FoundCell = SearchArea.Range("C:C").FindNext(After:=FoundCell) Loop While Not FoundCell Is Nothing And FoundCell.Address <> Addr ' If FoundCell.Offset(0, 1) <> TargetNo Then ' MsgBox "Not Find Number" ' End If End Sub

  • ユーザーフォーム　オプションボタン　について

    ユーザーフォーム内にオプションボタンを21個作っており、 Private Sub CommandButton1_Click() Dim SerchArea As Range '検索範囲(シート名指定） Set SearchArea = Sheets("1").Range(Range("A:A"), Range("A:A").End(xlDown)) '検索処理(引数：LookAt に xlWhole で完全一致 Set FoundCell = SearchArea.Find( _ What:=Me.TextBox1.Value, _ SearchOrder:=xlByRows, _ LookAt:=xlWhole, _ LookIn:=xlValues, _ MatchCase:=False) '商品コードが無い場合の処理 If FoundCell Is Nothing Then MsgBox "ありません！", vbCritical GoTo ExitHandler End If '見つかった場合の処理 With FoundCell Me.TextBox1.Value = .Offset(0, 0).Value Me.TextBox2.Value = .Offset(0, 11).Value Me.TextBox3.Value = .Offset(0, 12).Value Me.TextBox4.Value = .Offset(0, 4).Value テキストボックスにセルの値が入るようにしており、追加でオプションボタンを付けて更新としたいのですが、21個のうちどれか一つを選択して、その値をZ列に反映させたいのですが Private Sub CommandButton2_Click() With FoundCell .Offset(0, 13).Value = Me.TextBox20.Value .Offset(0, 4).Value = Me.TextBox4.Value .Offset(0, 5).Value = Me.TextBox5.Value ここの追加でオプションボタンを設定するにはどうすれば良いでしょうか？

  • 検索対象の行内容を代入してシートを印刷処理

    ワークシートにテキストファイルからデータを読み込み、その内容を別のフォーマットシートに貼り付けて印刷することを考えています。 今のところできているコードは以下の通りです。 Private Sub Workbook_Open() 'テキストデータを読み込み Dim Fname As String 'ファイル名 Dim rw As Long '書き出しの最初の行 Dim j As Long Dim u As Integer '配列の上限 Dim TextLine As String Dim LineBuf As Variant 'ラインバッファ Dim FNo As Integer 'ファイルNo Sheet1.Select Fname = Application.GetOpenFilename("tstnama(*.txt),*.txt") If Fname = "False" Then Exit Sub End If rw = 1 FNo = FreeFile() Open Fname For Input As #FNo 'ファイルインポート Do Until EOF(FNo) Line Input #FNo, TextLine LineBuf = Split(TextLine, "|") '配列の取り出し,区切り文字は、「|」 u = UBound(LineBuf) If u >= 0 Then ActiveSheet.Cells(rw + j, 1).Resize(, u + 1).Value = LineBuf End If j = j + 1 Loop Close #FNo '533の件数検索 Dim TargetStr As String, LastRow As Integer Dim TargetArea As Range, FoundCell As Range Dim R As Integer, N As Integer TargetStr = "533" LastRow = Cells(ActiveSheet.Rows.Count, 1).End(xlUp).Row Set TargetArea = Range(Cells(1, 1), Cells(LastRow, 1)) Set FoundCell = TargetArea.Find(what:=TargetStr, LookIn:=xlValues, _ LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _ MatchCase:=False) If Not FoundCell Is Nothing Then R = FoundCell.Row N = 1 Do Set FoundCell = TargetArea.FindNext(after:=FoundCell) If FoundCell.Row = R Then Exit Do N = N + 1 Loop Else MsgBox "該当データがありません", vbCritical End If Set FoundCell = TargetArea.FindPrevious(after:=FoundCell) '印刷件数の確認と印刷フェーズへの移行処理 If vbYes = MsgBox("B796K533は" & N & " 件です。印刷しますか？", vbYesNo) Then R = FoundCell.Row N = 1 Do With Sheet2 .Cells(4, 4).Value = Sheet1.Cells(R, 2).Value .Cells(5, 4).Value = Sheet1.Cells(R, 3).Value .Cells(6, 4).Value = Sheet1.Cells(R, 4).Value .Cells(7, 4).Value = Sheet1.Cells(R, 5).Value & " " & Sheet1.Cells(R, 6).Value & " " & Sheet1.Cells(R, 7).Value .Cells(8, 4).Value = Sheet1.Cells(R, 8).Value .Cells(9, 4).Value = Sheet1.Cells(R, 9).Value .PrintPreview End With MsgBox N & "枚目プリント" Set FoundCell = TargetArea.FindNext(after:=FoundCell) If FoundCell.Row = R Then Exit Do N = N + 1 Loop Else MsgBox "該当データがありません", vbCritical End If Set FoundCell = Nothing Set TargetArea = Nothing End Sub テキストファイルの内容はシートに貼り付けたとき8列になっておりA列には重複する番号が数パターン振られていて行当たりはダブりません。 A列にある特定の文字列(コード内では533)の件数を検索し、それぞれの行内容をシートに代入して、そのシートを印刷しますので 「533の数を確認(印刷される枚数を確認)」 ↓ 「検索された533の行内容を上から順番(A1~A*)に印刷」 という段取りで行きたいと思っています。 コードを走らせると、533の件数はちゃんと合うのですがその行内容が反映されません。変数Foundcellが印刷フェーズに入った段階でA1の行に固定されているようでその行内容が件数分印刷されてしまいます。(コードではPrintPreviewなのでプレビュー画面で確認しています。) Foundcellへの渡し方がわるいのでしょうか？それとも、やはり特定の行内容を取得するには別に主キーのようなものを振らなければだめでしょうか？ 533の後ろには534というように何パターンかあってそれらもあてがわれたフォーマットに代入して印刷していきたいので、これができれば後は繰り返しになりますから後一歩なのですが・・・。

  • 特定の文字以外を入力すると別シートに表記する方法

    Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Dim StrRow As Long Dim TgtCol As Long Dim MaxRow As Long Dim ChgRow As Long Dim PutSh1 As Worksheet Dim PutSh2 As Worksheet Dim PutSh3 As Worksheet Dim PutCol As Long Dim PutRow As Long Dim ChgRng1 As Range Dim ChgRng2 As Range Dim ChgRng3 As Range StrRow = 5 MaxRow = 35 If Target.Count > 1 Then Exit Sub If Target.Value = "" Then Exit Sub Set PutSh1 = ThisWorkbook.Sheets("Sheet2") Set PutSh2 = ThisWorkbook.Sheets("Sheet3") Set PutSh3 = ThisWorkbook.Sheets("Sheet4") With ThisWorkbook.Sheets("Sheet1") Set ChgRng1 = Range(.Cells(StrRow, 3), .Cells(MaxRow, 3)) 'C列 Set ChgRng2 = Range(.Cells(StrRow, 5), .Cells(MaxRow, 5)) 'E列 Set ChgRng3 = Range(.Cells(StrRow, 7), .Cells(MaxRow, 7)) 'G列 End With ChgRow = Target.Row If Not Intersect(Target, ChgRng1) Is Nothing Then Target.Offset(0, -1).Value = Target.Offset(0, -1).Value + 1 DataPut PutSh1, ChgRow, Target.Value End If If Not Intersect(Target, ChgRng2) Is Nothing Then Target.Offset(0, -1).Value = Target.Offset(0, -1).Value + 1 DataPut PutSh2, ChgRow, Target.Value End If If Not Intersect(Target, ChgRng3) Is Nothing Then Target.Offset(0, -1).Value = Target.Offset(0, -1).Value + 1 DataPut PutSh3, ChgRow, Target.Value End If End Sub 以前質問させて頂いた内容で追加の質問です。 Sheet1の指定したセルに「ー（ハイフン）」の文字がある時は、Sheet2〜4に転送（表記）しない方法を追加する場合はどの様にすれば宜しいでしょうか？

  • Find,Offsetを使ってセルを指定する方法

    エクセルVBAのことで伺います。 以下の記述は、「D3からQ3までのセルの中で「年」と入ったセルの左横のセルを探し、 その中の値（西暦の年が入っています）を、G4からI100までの範囲に入力される月日 の年として置き換える」といったものなのですが、エラーが出てしまいます。 「実行時エラー424、オブジェクトが必要です。」とのメッセージが表示され、デバックを クリックすると、「Set FoundCell = Range("D3:Q3").Find("年").Offset(0, -1).Select」 が黄色く強調表示されています。 プログラムの記述をどのように修正すれば良いか、どなたかお教えください。 よろしくお願いいたします。 Private Sub Worksheet_Change(ByVal Target As Range) Dim FoundCell As Range Set FoundCell = Range("D3:Q3").Find("年").Offset(0, -1).Select With Target If Intersect(Target, Range("G4:I100)) Is Nothing Or Target.Count <> 1 Then Exit Sub If IsDate(.Value) Then If Year(.Value) <> FoundCell Then Application.EnableEvents = False .Value = DateSerial(FoundCell, Month(.Value), Day(.Value)) Application.EnableEvents = True End If End If End With End Sub

  • ExcelVBA一致しない場合その他の行に集計する

    「ExcelVBA複数条件一致後別シートに結果表示」という質問を以前させていただき、丁寧にコードを解説していただきました。 ※その節はありがとうございました。 ●ファイルの内容(概要)配下の通りの構成です。 　＜Sheet1＞ 　　A列：性別(男性:1、女性:2でコード化) 　　B列：死因コード(数値5～6桁) 　　C列：年齢 　　D列：市町村(3桁でコード化「201」等) 　＜Sheet2＞Sheet1で条件に一致したものを以下の通り表を作成する 　　・「セルA1」に表にしたい市町村コードをあらかじめ入力しておく 　　・セルB1～セルEC1まで死因コード 　　・セルA2～セルA132まで年齢0～130 　　・セル範囲B2～EC132に「A1」に入力した市町村コードの男性の値が入る 　　・セルB133～セルEC133まで死因コード 　　・セルA134～A264まで年齢0～130 　　・セル範囲B134～EC264に「A1」に入力した市町村コードの女性の値が入る そして、以下のコードを教えていただきました。 **************************************************** Dim r As Long Dim i As Integer, j As Integer, k As Integer Dim Wsf As Object Dim SCode As Range, Nenrei As Range Dim Ws1 As Worksheet, Ws2 As Worksheet Set Ws1 = Worksheets("sheet1") Set Ws2 = Worksheets("sheet2") Set Wsf = Application.WorksheetFunction Application.ScreenUpdating = False Ws2.Range(Ws2.Cells(2, 2), Ws2.Cells(132, 133)).ClearContents Ws2.Range(Ws2.Cells(134, 2), Ws2.Cells(264, 133)).ClearContents With Ws2 Set SCode = .Range(.Cells(1, 1), .Cells(1, 133)) 　↑ここはこのように書いていただいたのから、 　指定の死因分類があったためシートから参照するようコードを変えています。 　手元にファイルが無くてかけないのが初心者の情けないところです。 　申し訳ありません。※シートは同一ファイル内におくようにしています。 End With r = 2 Do While Ws1.Cells(r, 1).Value <> "" If Ws1.Cells(r, 4).Value = Ws2.Cells(1, 1).Value Then If Ws1.Cells(r, 1).Value = 1 Then i = 1 ElseIf Ws1.Cells(r, 1).Value = 2 Then i = 134 End If With Ws2 Set Nenrei = .Range(.Cells(i, 1), .Cells(i + 130, 1)) End With j = i + Wsf.Match(Ws1.Cells(r, 3).Value, Nenrei, 0) - 1 k = Wsf.Match(Ws1.Cells(r, 2).Value, SCode, 0) Ws2.Cells(j, k).Value = Ws2.Cells(j, k).Value + 1 Else End If r = r + 1 Loop Application.ScreenUpdating = True Set Scode = Nothing Set Nenrei = Nothing Set Wsf = Nothing Set Ws1 = Nothing Set Ws2 = Nothing End Sub **************************************************** 表はあらかじめ作成しておくので、そこに集計結果が入ります。 実行していたら、古いファイルに不詳の死因コードが登場し、 どうしたらいいかと考えた結果、死因コードの列の最後に「その他」を設け、 死因コードに一致しない場合にはそこに集計結果をカウントすることは できないか？という考えに至りました。 自分で考えるのが一番勉強になると分かっていても試行錯誤している時間が無く、 急ぎのためお知恵のある方々にご協力を頂ければと思い、 再度質問させていただいた次第です。 前の質問は↓こちらです。 http://okwave.jp/qa/q8356291.html 何卒よろしくお願い申し上げます。

  • 重複データーの上書き

    行き詰っています。 よろしくお願いします。 下の構文では、 エラー：オブジェクトは、このプロパティまたはメソッドをサポートしていません と、表示されます。 ”コンボボックス1のデーターと重複しているセル（B2:B50)を探してその行の データーを上書きしたいのです” Private Sub CommandButton1_Click() Dim Mynumber As String Dim FoundCell As Range Sheets("ＡＡ").Range("B2:B50").Select Mynumber = ユーザーフォーム.コンボボックス1.Value Set FoundCell = Cells.Find(What:=Mynumber, After:=ActiveCell, _ LookIn:=xlFormulas, LookAt:=xlPart, _ SearchOrder:=xlByRows, _ SearchDirection:=xlNext, MatchCase:=False, _ MatchByte:=False) If FoundCell Is Nothing = False Then FoundCell.Select Sheets("ＡＡ").Offset(0, 0).Select = Me.コンボボックス1.Value Sheets("ＡＡ").Offset(0, 1).Select = Me.テキストボックス1.Value Sheets("ＡＡ").Offset(0, 2).Select = Me.テキストボックス2.Value Sheets("ＡＡ").Offset(0, 3).Select = Me.テキストボックス3.Value End If Exit Sub End Sub

  • Excel VBA テキストボックスを検索

    テキストボックス３に数値を入力し ExcelのA列にあるか検索をかける。 ある場合は、B列の同じ行に 「みーつけた！」と入力。 その設定で組んでみたのですが、 テキストボックス３にデータを6桁入力しようとすると 6桁目にオーバーフローエラーが出ます。 このプログラムの何処がおかしいのでしょうか？ Private Sub TextBox3_Change() Dim Number As Integer If TextBox3.Value <> "" Then '空じゃない場合 Number = TextBox3.Value Call 検索(Number) MsgBox TextBox3.Value End If End Sub Sub 検索(ByVal Number As Variant) Dim FoundCell As Range Set FoundCell = Range("A:A").Cells.Find(What:=Number, lookat:=xlPart) If FoundCell Is Nothing Then Else FoundCell.Activate Range("O" & ActiveCell.Row).Value = "みーつけた！" End If End Sub

  • 変数で指定したセルの値を取得して計算させるには？

    sub 単月発生残高の取得() Windows("総勘定元帳データ").Activate Worksheets(1).Activate Range("a2").Activate Dim sRange As Range, eRange As Range, tRange As Range, uRange As Range Dim j As Long, k As Long Dim i As Integer For i = 3 To Range("a2").End(xlDown).Row Set sRange = Cells(i, 1) Set eRange = sRange.End(xlToRight) Set tRange = eRange.Offset(2, 0) Set uRange = tRange.Offset(0, -1) j= tRange.value k= uRange.value Range("B1").formula="=k-j" Range("A1").value="単月発生残高" Next Set sRange = Nothing Set eRange = Nothing Set tRange = Nothing Set uRange = Nothing End Sub 上記のマクロを組んでみましたが、j= tRange.value のところでエラーになります。 uRangeの値からtRangeの値を引いた値を"B1"に表示させたいのですが、うまくいきません。 どうすればいいでしょうか。

注目のQ&A

カテゴリ

専門家に質問してみよう

職業から探して質問する

あなたにピッタリな商品が見つかる！ OKWAVEセレクト

質問する