締切済み

ExcelVBA　.cells(…　が働きません

2017/05/17 21:00

お世話になりますメモリーの、壁と格闘して、います其の、中で OfficeTANAKA様の http://officetanaka.net/excel/vba/tips/tips71.htm の、ページを拝見し Private Declare Sub GlobalMemoryStatus Lib "kernel32" (lpBuffer As MEMORYSTATUS) と、モジュールに、書き加えた、ところ With　Ws　　　↓此処、メソットがダメ　With　.Range(.cells(… が、突如エラーになり始めました Private Declare S… を、外して全て、元通りにしても回復、しません回復可能で、しょうか？宜しくお願い、します　　　　　　　　　　　　　　　　　記 Option　Explicit Option　Base　0 Private　Declare　Sub　GlobalMemoryStatus　Lib　"kernel32"　(lpBuffer　As　MEMORYSTATUS) '↑　　↑　　↑　　↑ '此れを、加えると Type　変数取得順速度差を減らす　s1　As　Long 　s2　As　Long 　Ch　As　Long 　du　As　Long 　St　As　String 　Rg　As　Range End　Type Const　n　As　Long　=　2000 Dim　lp　As　変数取得順速度差を減らす,　Data(1　To　n,　1　To　n)　As　Long,　k　As　Long,　Ws　As　Worksheets Sub　ダミーデータ作成1() 　Set　Ws　=　Worksheets.Add() 　Worksheets("Sheet1").Select 　With　Ws’　　　↓此処で、エラー　　With　.Range(.Cells(1,　1),　.Cells(n,　n)) 　　　Let　lp.St　=　"Min("　&　Ws.Name　&　"!"　&　.Address　&　")" 　　End　With 　　For　k　=　0　To　Int(n　/　100)　-　1 　　　For　lp.s2　=　1　To　100 　　　　For　lp.s1　=　1　To　n 　　　　　With　.Cells(k　*　100　+　lp.s2,　lp.s1) 　　　　　　.Formula　=　"=RANDBETWEEN(1,"　&　n　&　")" 　　　　　　.Calculate 　　　　　　.Value　=　.Value 　　　　　　Data(k　*　100　+　lp.s2,　lp.s1)　=　.Value 　　　　　End　With 　　　　Next　lp.s1 　　　Next　lp.s2 　　　Worksheets("Sheet1").Range("c1").Value　=　k 　　　Application.DisplayAlerts　=　False 　　　ThisWorkbook.Save 　　　Application.DisplayAlerts　=　True 　　Next　k 　　Set　lp.Rg　=　.Range(.Cells(1,　1),　.Cells(n,　n)) 　End　With End　Sub 　　　　　　　　　　　　　　　　　　　　　　　　　　　　　以上

Nouble
お礼率91% (1698/1856)

Excel（エクセル）
回答数2
ありがとう数2

みんなの回答 （2）
専門家の回答

みんなの回答

imogasi
ベストアンサー率27% (4737/17068)

2017/05/17 23:13 回答No.2

#1です。補記します。 http://www.asahi-net.or.jp/~ef2o-inue/vba_k/sub04_200_070.html の真ん中以後あたりを読んでみてください。

質問者

お礼 2017/05/18 05:02

拝見しました此は、本当につい、最近はまった、事でしてお恥ずかしい　汗要するに此処に、記載されている、事は「．」付与のバラつきに、よる Withの、継承関係の適用、不適用、等、選択シートの、不整合問題ですよね？今一度確認、しましたが点はちゃんと、全てに付与、されていますお心に留めて、頂き感謝、です MAC、2011でご法度行為だった、のか？と、感じて、います Windows向け、記載ですし "kernel32"の、Libを入れては、駄目だったの、かも？

質問者

補足 2017/05/18 05:07

此、「Windowsの、APi呼び出し」じゃ、ないですか私、馬鹿だ　汗 MACじゃ、駄目に決まってますよね？なんとか回復、だけでも出来れば、良いの、ですが

imogasi
ベストアンサー率27% (4737/17068)

2017/05/17 23:07 回答No.1

With　.Range(.Cells(1,　1),　.Cells(n,　n)) などのCellsのそれぞれの直前の位置に Set　Ws　=　Worksheets.Add()から由来する「Ｗｓ.」をくっつけて実行してどうなりますか。 With　Ws.Range(.Ws.Cells(1,　1),　WS.Cells(n,　n)) Ｒaｎｇｅの前にも付けてみました。Ｇｒｏｂａｌ・・とかでて止まるのでしょう。なぜ（の中までＷｉｔｈが及ばないのかよく説明できませんが、とりあえず。

質問者

お礼 2017/05/18 04:45

有難うございます〉突如エラーにと、書かせて、頂きましたが正に此の、通り直前、までは何ら、問題なく動いて、いました With　Ws は、正常に機能して、いた訳、ですウオッチウインドウ時、には恐らくは、 withが、使えないと、私は、勝手に思って、いますが其の、関係で〉Ws.RAnge(Ws.Cells(… は、ウオッチウインドウベース、ながら幸いにも、試しており結果は、エラー変わりませんでした

関連するQ&A

EXCEL2011 Objectに入れたWork…
お世話になります。どうもよく、解らないの、ですが下記でコメントアウト、させているラインの、内＊印を、付けているどの行、をもコメントアウトから、戻すと ☆で、添付映像のエラーに、なりますコメントアウトの、ままだとエラーには、なりません察するに Wsが ActiveSheetで、無いと with　Ws に、対する .Range(cells(… が、嫌っぽいの、ですがこんな事、当たり前なのか疑問、なのですお教え下さい。　　　　記 Option　Explicit Option　Base　0 Dim　Data(100,　100)　As　Long,　Ch　As　Long,　s1　As　Long,　s2　As　Long,　Ws　As　Worksheet,　すとり　As　Range Sub　testMain()　'　簡易テスト Dim　現状保存　As　Worksheet,　シート名　As　String 　Let　シート名　=　ActiveSheet.Name Application.ScreenUpdating　=　False 　Worksheets(シート名).Copy　after:=Worksheets(Worksheets.Count)　　'■ 　Set　現状保存　=　ActiveSheet　　　　　　　　　　　　　　　　　　　　　　　　　　　　'■ 　Set　Ws　=　Worksheets.Add() '　Worksheets(シート名).Copy　after:=Worksheets(Worksheets.Count)　　'＊□ '　Set　現状保存　=　ActiveSheet　　　　　　　　　　　　　　　　　　　　　　’□ '　Worksheets(シート名).Select　　　　　　　　　　　　　　　　　　　　'＊　現状保存.Visible　=　False '　Ws.Visible　=　False　　　　　　　　　　　　　　　　　　　　　　　'＊ Application.ScreenUpdating　=　True 　Call　ダミーデータ作成　Call　testC 　Call　testV 　Call　testE Application.DisplayAlerts　=　False 現状保存.Delete Ws.Delete Application.DisplayAlerts　=　True End　Sub Sub　ダミーデータ作成() 　With　Ws.Range("a1:cv100") 　　.Formula　=　"=RANDBETWEEN(1,10000)" 　　.Calculate 　　.Value　=　.Value 　End　With 　Let　Ws.Cells(1,　101).Formula　=　"=MIN("　&　Ws.Name　&　"!"　&　Ws.Range("a1:cv100").Address　&　")" 　Ws.Cells(1,　101).Calculate 　For　s2　=　1　To　100 　　For　s1　=　1　To　100 　　　Data(s1,　s2)　=　Ws.Cells(s1,　s2).Value 　　Next　s1 　Next　s2 　Let　Data(0,　0)　=　Ws.Cells(1,　101).Value End　Sub Sub　testC() 　Ch　=　10000 　With　Ws 　　For　s2　=　1　To　100 　　　For　s1　=　1　To　100 　　　　If　Ch　>　.Cells(s1,　s2).Value　Then　Ch　=　.Cells(s1,　s2).Value 　　　Next 　　Next 　End　With End　Sub Sub　testV() 　Ch　=　10000 　　For　s2　=　1　To　100 　　　For　s1　=　1　To　100 　　　　If　Ch　>　Data(s1,　s2)　Then　Ch　=　Data(s1,　s2) 　　　Next 　　Next End　Sub Sub　testE() 　With　Ws 　　すとり　=　.Range(Cells(1,　1))　　　　　　　　　　　　　　　　　'☆ 　End　With End　Sub (※注:□の2行を　コメントから　外す、時は　同、■の2行を　コメントアウトして、下さい) 　　　　　　　　　　　　　　　　　　　　　　以上
- ベストアンサー
- Excel（エクセル）
VBA Range・Cellsプロパティについて
下記のコードについて質問致します。 Sub 特定のセルをコピー() Dim rw2 As Long Dim rw1 As Long Dim newdate As Date With Worksheets("steet1") rw2 = .cells(.Rows.Count, "c").End(xlUp).Row newdate = .Range("c" & rw2).value For rw1 = rw2 - 1 To 1 Step -1 If .Range("c" & rw1).value <> newdate Then Exit For Next rw1 .Range(.cells(rw1 + 1, 1), .cells(rw2, 1)).Copy 　　　 '(1) Worksheets("steet2").Range("v6").PasteSpecial xlValue End With End Sub (1)部分のコードの意味が分かりません。よろしくお願いします。
- ベストアンサー
- Visual Basic
EXCEL2011 Objectに入れたWoｒ…改
お世話になります。どうもなんと言って良いのか本当に、済みませんスレットを、変えようと、して念の、ため確認に、再度走らせて、みたの、ですがコメントアウト、させていても ☆で、添付映像のエラーに、なりますもう頭が？？？？？？です兎に角エラー理由が、解りません申し訳、ありませんがお教え下さい。　　　　記 Option　Explicit Option　Base　0 Dim　Data(100,　100)　As　Long,　Ch　As　Long,　s1　As　Long,　s2　As　Long,　Ws　As　Worksheet,　ランゲ　As　Range Sub　testMain()　'　簡易テスト Dim　現状保存　As　Worksheet,　シート名　As　String 　Let　シート名　=　ActiveSheet.Name Application.ScreenUpdating　=　False 　Worksheets(シート名).Copy　after:=Worksheets(Worksheets.Count)　　'■ 　Set　現状保存　=　ActiveSheet　　　　　　　　　　　　　　　　　　　　　　　　　　　　'■ 　Set　Ws　=　Worksheets.Add() '　Worksheets(シート名).Copy　after:=Worksheets(Worksheets.Count)　　'＊□ '　Set　現状保存　=　ActiveSheet　　　　　　　　　　　　　　　　　　　　　　’□ '　Worksheets(シート名).Select　　　　　　　　　　　　　　　　　　　　'＊　現状保存.Visible　=　False '　Ws.Visible　=　False　　　　　　　　　　　　　　　　　　　　　　　'＊ Application.ScreenUpdating　=　True 　Call　ダミーデータ作成　Call　testC 　Call　testV 　Call　testE Application.DisplayAlerts　=　False 現状保存.Delete Ws.Delete Application.DisplayAlerts　=　True End　Sub Sub　ダミーデータ作成() 　With　Ws.Range("a1:cv100") 　　.Formula　=　"=RANDBETWEEN(1,10000)" 　　.Calculate 　　.Value　=　.Value 　End　With 　Let　Ws.Cells(1,　101).Formula　=　"=MIN("　&　Ws.Name　&　"!"　&　Ws.Range("a1:cv100").Address　&　")" 　Ws.Cells(1,　101).Calculate 　For　s2　=　1　To　100 　　For　s1　=　1　To　100 　　　Data(s1,　s2)　=　Ws.Cells(s1,　s2).Value 　　Next　s1 　Next　s2 　Let　Data(0,　0)　=　Ws.Cells(1,　101).Value End　Sub Sub　testC() 　Ch　=　10000 　With　Ws 　　For　s2　=　1　To　100 　　　For　s1　=　1　To　100 　　　　If　Ch　>　.Cells(s1,　s2).Value　Then　Ch　=　.Cells(s1,　s2).Value 　　　Next 　　Next 　End　With End　Sub Sub　testV() 　Ch　=　10000 　　For　s2　=　1　To　100 　　　For　s1　=　1　To　100 　　　　If　Ch　>　Data(s1,　s2)　Then　Ch　=　Data(s1,　s2) 　　　Next 　　Next End　Sub Sub　testE() 　With　Ws 　　Set　ランゲ　=　.Range(Cells(1,　1))　　　　　　　　　　　　　　　'☆ 　End　With End　Sub (※注:□の2行を　コメントから　外す、時は　同、■の2行を　コメントアウトして、下さい) 　　　　　　　　　　　　　　　　　　　　　　以上
- ベストアンサー
- Excel（エクセル）
ExcelVBA Dictionaryオブジェクト
こんにちは。 Dictionaryオブジェクトについて、ご教示いただきたく質問させていただきます。あるCSVデータにおいて、A列に入力されている番号で重複をなくし、重複する番号については、B列(売上額)C列(利益額)それぞれの値を合計してSheet2に表示させるコード(test1)を書きました。データの行数が3万5千行ほどあるため、処理が終わるのに3分程かかります。今後もデータは増えていくので、処理終了までの時間をもう少し短縮したく、自分なりに調べてみたところ、Dictionaryオブジェクトというものを知り、使用例を参考にしながら見よう見まねでコード(test2)を書いて試してみたところ、処理終了まで数秒となり、かなり短縮されました。エラーも出ることなく処理できるものの、Dictionaryオブジェクトに対する理解がイマイチでして、コードの書き方等、問題ないかを知りたく質問させていただいた次第です。よろしくお願いいたします。 ------------------------------------------------------------------------------ Sub test1() Dim i As Long Dim lastRow As Long Dim ws As Worksheet Application.ScreenUpdating = False '不要データ削除 Rows("1:3").Select Selection.Delete Shift:=xlUp Range("B:Q,S:W,Y:AF").Select Selection.Delete Shift:=xlToLeft Range("A1").Select 'シート名変更・挿入 ActiveSheet.Name = "CSV" Sheets.Add After:=ActiveSheet ActiveSheet.Name = "売利集計" Set ws = Worksheets("売利集計") wS.Cells.ClearContents ws.Range("B1").Value = Worksheets("CSV").Range("B1") ws.Range("C1").Value = Worksheets("CSV").Range("C1") With Worksheets("CSV") .Range("A:A").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=ws.Range("A1"), unique:=True lastRow = ws.Cells(Rows.Count, "A").End(xlUp).Row With Range(ws.Cells(2, "B"), ws.Cells(lastRow, "B")) .Formula = "=SUMIF(CSV!A:A,A2,CSV!B:B)" .Value = .Value End With With Range(ws.Cells(2, "C"), ws.Cells(lastRow, "C")) .Formula = "=SUMIF(CSV!A:A,A2,CSV!C:C)" .Value = .Value End With End With Application.ScreenUpdating = True Set ws = Nothing MsgBox "売利集計完了しました。" End Sub Sub test2() Dim i As Long Dim lastRow As Long Dim ws As Worksheet Dim c As Range Dim dicS As Object Dim dicP As Object Application.ScreenUpdating = False '不要データ削除 Rows("1:3").Select Selection.Delete Shift:=xlUp Range("B:Q,S:W,Y:AF").Select Selection.Delete Shift:=xlToLeft Range("A1").Select 'シート名変更・挿入 ActiveSheet.Name = "CSV" Sheets.Add After:=ActiveSheet ActiveSheet.Name = "売利集計" '番号別集計 Set ws = Worksheets("売利集計") Set dicS = CreateObject("Scripting.Dictionary") Set dicP = CreateObject("Scripting.Dictionary") With Sheets("CSV") For Each c In .Range("A2", .Range("A" & .Rows.Count).End(xlUp)) dicS(c.Value) = dicS(c.Value) + Val(c.Offset(, 1).Value) dicP(c.Value) = dicP(c.Value) + Val(c.Offset(, 2).Value) Next With Worksheets("売利集計") .Columns("A:C").ClearContents .Range("A1").Resize(, 3).Value = Worksheets("CSV").Range("A1").Resize(, 3).Value .Range("A2").Resize(dicS.Count).Value = WorksheetFunction.Transpose(dicS.keys) .Range("B2").Resize(dicS.Count).Value = WorksheetFunction.Transpose(dicS.Items) .Range("C2").Resize(dicP.Count).Value = WorksheetFunction.Transpose(dicP.Items) End With End With Set dicS = Nothing Set dicP = Nothing MsgBox "売利集計完了しました。" End Sub
- 締切済み
- Excel（エクセル）
マクロが思うように動きません
エクセル2007です。初心者です。マクロが思うように動きません。指定のセルが空白の場合、msgboxを表示して、処理を抜ける空白でない場合は、処理をつつける。と言う事をしたいです。 with～の後が問題だと思うのですが・・ Sub 受注履歴書き込み() Dim ws01 As Worksheet, ws02 As Worksheet Dim r As Long, c As Integer, tmp As Long Set ws01 = Worksheets("受注書") Set ws02 = Worksheets("受注履歴") ws01.Activate With ws01 If .Range("C2").Value = "" _ And .Range("M2").Value = "" _ And .Range("M11").Value = "" _ And Worksheets("粗利報告書").Range("D3").Value = "" Then MsgBox "受注Noが空白です。処理を中止します。" Exit Sub ws02.Cells(r, 1).Value = .Range("C2").Value ' 受注No ws02.Cells(r, 9).Value = .Range("A40").Value ' 備考 ws02.Activate End If End With End Sub 採点願えますでしょうか？宜しくお願い致します。
- ベストアンサー
- オフィス系ソフト
VBA 検索するSheetの位置の変更
現在、グループの数だけユーザー名の合計数をSheet2に抽出するという事をやっているのですが....... コードの方は下記になります Sub Sample3() Dim i As Long, j As Long, k As Long, lastRow As Long, lastCol As Long Dim wS2 As Worksheet, wS3 As Worksheet Set wS2 = Worksheets("Sheet1") Set wS3 = Worksheets("Sheet2") Application.ScreenUpdating = False If wS2.Range("Y1") = "" Then wS2.Range("Y1") = "ダミー" End If With Worksheets("Sheet1") If .Range("A4") = "" Then .Range("A4") = "ダミー" End If lastRow = .Cells(Rows.Count, "B").End(xlUp).Row Range(.Cells(5, "B"), .Cells(lastRow, "B")).AdvancedFilter Action:=xlFilterCopy, copytorange:=wS3.Range("A1"), unique:=True '★ For i = 2 To wS3.Cells(Rows.Count, "A").End(xlUp).Row wS2.Cells(7, (i - 2) * 8 + 3) = wS3.Cells(i, "A") .Range("A4").AutoFilter field:=2, Criteria1:=wS3.Cells(i, "A") Range(.Cells(5, "AA"), .Cells(lastRow, "AA")).SpecialCells(xlCellTypeVisible).Copy wS2.Cells(7, (i - 2) * 8 + 2) For k = wS2.Cells(Rows.Count, (i - 2) * 8 + 2).End(xlUp).Row To 7 Step -1 wS2.Cells(k, (i - 2) * 8 + 3) = WorksheetFunction.CountIfs(.Range("AA:AA"), wS2.Cells(k, (i - 2) * 8 + 2), .Range("B:B"), _ wS2.Cells(7, (i - 2) * 8 + 3)) If WorksheetFunction.CountIf(wS2.Columns((i - 2) * 8 + 2), wS2.Cells(k, (i - 2) * 8 + 2)) > 1 Then wS2.Cells(k, (i - 2) * 8 + 2).Resize(, 2).Delete shift:=xlUp End If Next k Next i wS2.Range("B1").CurrentRegion.Borders.LineStyle = xlContinuous wS2.Cells.Replace what:="ダミー", replacement:="", lookat:=xlWhole .Cells.Replace what:="ダミー", replacement:="", lookat:=xlWhole wS3.Cells.Clear .AutoFilterMode = False End With Application.ScreenUpdating = True End Sub このコードで検索をかけるSheet1のセルBの文字をセルCに移動して検索かけたいという事なのですが、下記の用なコードでBをCに変更してみた結果エラーが発生してしまいます。 lastRow = .Cells(Rows.Count, "C").End(xlUp).Row Range(.Cells(5, "C"), .Cells(lastRow, "C")).AdvancedFilter Action:=xlFilterCopy, copytorange:=wS3.Range("A1"), unique:=True '★ For i = 2 To wS3.Cells(Rows.Count, "A").End(xlUp).Row wS2.Cells(7, (i - 2) * 8 + 3) = wS3.Cells(i, "A") .Range("A4").AutoFilter field:=2, Criteria1:=wS3.Cells(i, "A") Range(.Cells(5, "AA"), .Cells(lastRow, "AA")).SpecialCells(xlCellTypeVisible).Copy wS2.Cells(7, (i - 2) * 8 + 2) For k = wS2.Cells(Rows.Count, (i - 2) * 8 + 2).End(xlUp).Row To 7 Step -1 wS2.Cells(k, (i - 2) * 8 + 3) = WorksheetFunction.CountIfs(.Range("AA:AA"), wS2.Cells(k, (i - 2) * 8 + 2), .Range("C:C"), _ どなたかご教授の方お願い致します。
- ベストアンサー
- Visual Basic
エクセルの複数条件抽出
エクセルで複数条件のカウントをしようと思い、下のマクロを作成しました。うまくカウントができないのですが、どこらへんが間違っていますでしょうか？（実際にはもっと多くのデータで利用を予定しており、小さいものでテストしています）よろしくお願いします。 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
- 締切済み
- オフィス系ソフト
シート1の氏名をシート2に反映
sheet1の氏名をsheet2の日付、記号（A,B,C）にマッチした位置に入力させたいのですが下記コードで他で試したのですがうまくいきません。どなたかコードが解る方よろしくお願いします。 Sub 入力() Dim i As Long, j As Long, k As Long, L As Long Dim wS1 As Worksheet, wS2 As Worksheet Set wS1 = Worksheets("Sheet1") Set wS2 = Worksheets("Sheet2") i = wS2.Range(wS2.Cells(6, 1), wS2.Cells(8, 1)) j = wS2.Cells(3, Columns.Count).End(xlToLeft).Column Range(wS2.Cells(3, 2), wS2.Cells(i, j)).ClearContents On Error Resume Next For i = 2 To wS1.Cells(Rows.Count, 4).End(xlUp).Row If WorksheetFunction.CountA(wS1.Rows(i)) > 1 Then For j = 2 To wS1.Cells(i, Columns.Count).End(xlToLeft).Column If wS1.Cells(i, j) <> "" Then k = WorksheetFunction.Match(wS1.Cells(i, 4), wS2.Range(wS2.Cells(6, 1), wS2.Cells(8, 1)), False) L = WorksheetFunction.Match(wS1.Cells(5, j), wS2.Rows(3), False) wS2.Cells(k, L) = wS1.Cells(i, j) End If Next j End If Next i End Sub
- ベストアンサー
- Visual Basic
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 何卒よろしくお願い申し上げます。
- ベストアンサー
- Visual Basic
ExcelVBAについて
以上～以下検索についてです。現在、1文字以上一致で検索し、listboxに検索結果を表示させることができますコードは下記 Private Sub CommandButton1_Click() Dim lastRow As Long Dim myData, myData2(), myno Dim i As Long, j As Long, cn As Long With Workbooks("Master.xlsm").Worksheets("Sheet1") myData = .Range(.Cells(3, 2), .Cells(Rows.Count, 5).End(xlUp)).Value lastRow = .Cells(Rows.Count, 2).End(xlUp).Row End With ReDim myData2(1 To lastRow, 1 To 4) For i = LBound(myData) To UBound(myData) If myData(i, 2) Like "*" & TextBox2.Value & "*" And _ myData(i, 3) Like "*" & TextBox3.Value & "*" And _ myData(i, 4) Like "*" & TextBox4.Value & "*" _ Then cn = cn + 1 myData2(cn, 1) = myData(i, 1) myData2(cn, 2) = myData(i, 2) myData2(cn, 3) = myData(i, 3) myData2(cn, 4) = myData(i, 4) End If Next i If cn = 0 Then MsgBox "検索結果は見つかりませんでした・・・" Else End If With ListBox1 .ColumnCount = 4 .ColumnWidths = "20;40;20;60" End With End Sub そして今回教えていただきたいのが userfoamで例えば,金額が1000～100000の間のものを検索し、それに該当するものすべてをリストボックスに表示させることです。このコードに以上～以下検索を追加するにはどうすればいいでしょうか？新しい方法、これよりいい方法があればお教えください。よろしくお願いいたします。
- ベストアンサー
- Visual Basic

ExcelVBA　.cells(…　が働きません