• 締切済み

エクセル マクロ 範囲指定。

先日、OKWAVEのサイトでエクセルマクロの質問をさせていただき 下記の回答を活用したいのでしが myKey = Worksheets("Sheet2").Range("A1").ValueをA1A2・・・A50のように 50個を一度に処理したいのですがどのように変更すればよろしいのでしようか 自分なりに調べてみましたが知識がなくできませんでした ご回答のいただいたmitarashiさんにお聞きしたいのですがお聞きする手段がわからず 再度、質問させていただきます。                       宜しくお願いいたします。 Sub test() Dim targetRange As Range Dim buf As Variant Dim i As Long, j As Long, myColorIndex As Long Dim myKey As Variant Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Set targetRange = Worksheets("Sheet1").Range("J10:BB10000") buf = targetRange myColorIndex = 4 myKey = Worksheets("Sheet2").Range("A1").Value With targetRange For i = 1 To UBound(buf, 1) For j = 1 To UBound(buf, 2) If buf(i, j) = myKey Then .Cells(i, j).Interior.ColorIndex = myColorIndex Next j Next i End With Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic End Sub

みんなの回答

  • mitarashi
  • ベストアンサー率59% (574/965)
回答No.4

n-junさんのCountIf案面白そうなので試してみましたが、残念ながら3重ループに比べてかなり遅かったです。 #1,2同様、ただし、Worksheets("Sheet2").Range("A1:A100")も配列に入れてループを回すと、15秒前後でしたが、CountIFだと、十数倍かかりました。(xl2010,大昔のシングルコアCeleron2.4GHz) ただ、http://okwave.jp/qa/q7234627.htmlで、中途半端な回答にとどめたのは理由があります。 処理が10数秒で終わっても、だだっ広いシートを眺めていると、直ぐに数分経ってしまいそうなので、本当にやりたいのは何なのか、どんなOutputが欲しいのか補足をお待ちしていたものです。 さすがに、回答してから数日空くと、リアクションは無いものと見切りをつけてしまいますので、補足は早めにお願いいたします。

fukuzawakamon
質問者

お礼

mitarashiさん ご回答ありがとうございます。 補足等が遅くなり申し訳ありませんでした。 私の質問させていただく準備が整ってから再度、質問させていただきます。 たいへん申し訳ありませんでした。

  • n-jun
  • ベストアンサー率33% (959/2873)
回答No.3

検証していないけど、 COUNTIF関数とか使えばいいのでは? Sub test() Dim targetRange As Range Dim buf As Variant Dim i As Long, j As Long, myColorIndex As Long 'Dim myKey As Variant Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Set targetRange = Worksheets("Sheet1").Range("J10:BB10000") buf = targetRange myColorIndex = 4 'myKey = Worksheets("Sheet2").Range("A1").Value With targetRange For i = 1 To UBound(buf, 1) For j = 1 To UBound(buf, 2) If WorksheetFunction.CountIf(Worksheets("Sheet2").Range("A1:A50"), buf(i, j)) > 0 Then .Cells(i, j).Interior.ColorIndex = myColorIndex Next j Next i End With Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic End Sub

fukuzawakamon
質問者

お礼

ご回答ありがとうございます 実行してみましたが途中でパソコンが固まって動かない状態になりました。 他に原因があると思いますので再度、実行してみます。

  • DreamyCat
  • ベストアンサー率56% (295/524)
回答No.2

for j=1 to 50 myKey = Worksheets("Sheet2").Range("A" & j).Value とか myKey = Worksheets("Sheet2").cells(j,1).Value のようにしてください。 rangeとcellsでは行と列を記述する順番が逆なので気をつけてください。

fukuzawakamon
質問者

お礼

ご回答ありがとうございます。

  • yucco_chan
  • ベストアンサー率48% (828/1705)
回答No.1

Sub test() Dim targetRange As Range Dim buf As Variant Dim i As Long, j As Long, myColorIndex As Long Dim myKey As Variant '---追加 dim k as long '---追加終わり Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Set targetRange = Worksheets("Sheet1").Range("J10:BB10000") buf = targetRange myColorIndex = 4 '---追加 for k=1 to 100 '1はSheet2のA1の1、100は、A100の100の意。適宜修正してください '---修正 myKey = Worksheets("Sheet2").Range("A" & k).Value 'myKey = Worksheets("Sheet2").Range("A1").Value '----追加修正終わり With targetRange For i = 1 To UBound(buf, 1) For j = 1 To UBound(buf, 2) If buf(i, j) = myKey Then .Cells(i, j).Interior.ColorIndex = myColorIndex Next j Next i End With '---追加 next k '---追加終わり Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic End Sub

fukuzawakamon
質問者

お礼

ご回答ありがとうございます。 申し訳ありません 途中で固まってしまいます 別の原因を解決してから再度、実行してみます。

関連するQ&A

  • エクセルマクロで変数を使ったセル範囲指定

    Dim x As Long Dim y As Long として x = Range("A1").End(xlDown).Row For y = 1 To x としました。 このときRange("A" & y)からRange("A" & x)を範囲指定したいときは どのように記述すればよいのでしょうか?

  • エクセルのマクロ

    下記のマクロを実行するといつも.Findのところでフリーズしてしまいます。 同じ方法で違うBookからの取込には不具合はないのですが、何故だかわかりません。 ちょっと長くなりますが、どなたか教えてください。 'Function fn_KAKUNIN_Update(strSheetName As String, strInBookName As String) '変数宣言 Dim wksInSheet As Worksheet '入力シート Dim wkbInBook As Workbook '入力ブック Dim wksUpSheet As Worksheet '更新するシート Dim lngKAKUNIN_MaxRow As Long Dim lngSYACHO_MaxRow As Long Dim intMsg As Integer Dim strGenbaNo As String Dim i As Long Dim j As Long Dim rngFind As Range Dim lngStrNo As Long Set wkbInBook = Workbooks(strInBookName) Set wksInSheet = wkbInBook.Worksheets Set wksUpSheet = Workbooks(pstrBookName).Worksheets(strSheetName) fn_KAKUNIN_Update = 1 lngKAKUNIN_MaxRow = wksInSheet.Range("C4").CurrentRegion.Rows.Count lngSYACHO_MaxRow = wksUpSheet.Range("H4").CurrentRegion.Rows.Count lngStrNo = 4 For i = lngStrNo To lngSYACHO_MaxRow strGenbaNo = wksUpSheet.Range("H" & i) With wksInSheet.Range("C4:C" & lngKAKUNIN_MaxRow) Set rngFind = .Find(strGenbaNo, LookIn:=xlValues, MatchCase:=False) If rngFind Is Nothing Then Else

  • ExcelのVBAの配列に関する質問です。

    ExcelのVBAの配列に関する質問です。 sheet1のデータをsheet2に表示するVBAを作成しています。。 sheet1のデータは7行目からスタートし、sheet2のデータは26行目からスタートしています。。 sheet1とsheet2の列は同じ並びではないため、それぞれのシートの列番号をCellsを用いて指定しています。 Sub test1() Dim endrow As Long endrow = Worksheets("sheet1").Range("A65536").End(xlUp).Row Dim i As Long Dim j As Long For i = 7 To endrow j = i + 19 Worksheets("sheet2").Cells(j, 1) = Worksheets("sheet1").Cells(i, 2) Worksheets("sheet2").Cells(j, 8) = Worksheets("sheet1").Cells(i, 28) Worksheets("sheet2").Cells(j, 9) = Worksheets("sheet1").Cells(i, 31) Worksheets("sheet2").Cells(j, 10) = Worksheets("sheet1").Cells(i, 32) ・ ・ ・ ※長いので省略 Next i End Sub 上記のtest1は正常に動くのですが、データ量が多いため、処理に時間がかかってしまいます。 高速化できないかと、以下のように変更しました。 Sub test2() Dim dataRange1 As Variant Dim dataRange2 As Variant dataRange1 = Worksheets("sheet1").Range("A1:GI10006") dataRange2 = Worksheets("sheet2").Range("A1:DZ10018") Dim endrow As Long endrow = Worksheets("sheet1").Range("A65536").End(xlUp).Row Dim i As Long Dim j As Long For i = 7 To endrow j = i + 19 dataRange2(j, 1) = dataRange1(i, 2) dataRange2(j, 8) = dataRange1(i, 28) dataRange2(j, 9) = dataRange1(i, 31) dataRange2(j, 10) = dataRange1(i, 32) ・ ・ ・ ※長いので省略 Next i End Sub test2は、エラーメッセージ等は表示されませんが、sheet2にデータが表示されません。 ちなみに、以下のようにsheet1のみ配列化した場合は、正常に表示されました。 Worksheets("sheet2").Cells(j, 1) = dataRange1(i, 2) Worksheets("sheet2").Cells(j, 8) = dataRange1(i, 28) Worksheets("sheet2").Cells(j, 9) = dataRange1(i, 31) Worksheets("sheet2").Cells(j, 10) = dataRange1(i, 32) test2は、どこが間違っているのでしょうか? ご教示ください。 よろしくお願いいたします。

  • エクセルののマクロについて教えてください

    Sub search() Dim i As Long, lastCol As Long, c As Range, str As String, wS As Worksheet Set wS = Worksheets("sheet2") wS.Cells.Clear str = Application.InputBox("検索内容を入力") Application.ScreenUpdating = False With Worksheets("sheet1") lastCol = .Cells(1, Columns.Count).End(xlToLeft).Column .Columns(lastCol + 1).Insert For i = 2 To .Cells(Rows.Count, "A").End(xlUp).Row Set c = Range(.Cells(i, "A"), .Cells(i, lastCol)).Find(what:=str, LookIn:=xlValues, lookat:=xlWhole) If Not c Is Nothing Then .Cells(i, lastCol + 1) = 1 End If Next i If WorksheetFunction.CountIf(.Columns(lastCol + 1), 1) > 0 Then .Range("A1").AutoFilter field:=lastCol + 1, Criteria1:=1 .Range("A1").CurrentRegion.SpecialCells(xlCellTypeVisible).Copy wS.Range("A1") wS.Columns.AutoFit wS.Columns(lastCol + 1).Delete wS.Activate .Columns(lastCol + 1).Delete .AutoFilterMode = False Else MsgBox "該当データなし" End If End With Application.ScreenUpdating = True End Sub エクセルで上のシステムをネットから持ってきました。 上から5行目のinputboxを"Sheet3"のA列からデータを持ってきてプルダウンで表示させたいのですがユーザーフォームでオブジェクトを組まないで表示させる方法を教えてください

  • エクセル2010でマクロが動きません

    こんにちは。 マクロ超初心者です。 頑張ってエクセル2016でマクロ作成しましたが、エクセル2010で途中から動かず…。 何が悪いんでしょうか… ここから動きません…と書いたところから動きません(涙) Private Sub シート編集_Click() Application.ScreenUpdating = False Dim i Dim Sh1 As Worksheet Dim Sh2 As Worksheet Dim Sh4 As Worksheet Set Sh1 = Worksheets("あ") Set Sh2 = Worksheets("い") Set Sh4 = Worksheets("う") Dim dayCutoff As Date dayCutoff = Application.InputBox("年月日を入力してください", "お支払期限 年月日を入力", Format(Date, "yyyy/mm/dd")) Sh4.Range("D12").Value = DateSerial(Year(dayCutoff), Month(dayCutoff) + 2, 0) 'お支払期限 dayCutoff = Application.InputBox("年月日を入力してください", "請求書発行 日を入力", Format(Date, "yyyy/mm/dd")) Sh4.Range("AC3").Value = Format(Date, "yyyy/mm/dd") '発行日 Sh1.Cells.Clear With Sh1 'edit .Range("A2") = "番号" .Range("B2") = "会社名" .Range("C2") = "判定" .Range("D2") = "契約番号" .Range("E2") = "拠点" .Range("F2") = "税率" .Range("G2") = "月額(税抜)" .Range("H2") = "消費税" .Range("I2") = "月額(税込)" .Range("J2") = "今回" .Range("K2") = "全回" .Range("L2") = "店番" ここから動きません………… For i = 3 To Sh2.Cells(.Rows.Count, 1).End(xlUp).Row .Cells(i, 1) = Sh2.Cells(i, 2) .Cells(i, 2) = Sh2.Cells(i, 4) .Cells(i, 4) = Sh2.Cells(i, 3) .Cells(i, 5) = Sh2.Cells(i, 4) & "(" & Sh2.Cells(i, 6) & ")" .Cells(i, 6) = Sh2.Cells(i, 9) & "%課税" .Cells(i, 7) = Sh2.Cells(i, 8) .Cells(i, 8) = Sh2.Cells(i, 10) .Cells(i, 9) = Sh2.Cells(i, 11) .Cells(i, 10) = Sh2.Cells(i, 12) .Cells(i, 11) = Sh2.Cells(i, 7) .Cells(i, 12) = Sh2.Cells(i, 2) If Sh1.Cells(i, 10) > Sh1.Cells(i, 11) Then .Cells(i, 3) = "×" Else .Cells(i, 3) = "〇" End If If Sh1.Cells(i, 3) = "×" Then .Cells(i, 2) = "" End If Next i End With '空白行を削除 Dim j As Integer, myFlag As Boolean Dim c As Range With Worksheets("edit").Range("A2").CurrentRegion For j = .Rows.Count To 2 Step -1 myFlag = False For Each c In .Cells(j, 2) If c.Value <> "" Then myFlag = True Exit For End If Next If myFlag = False Then .Rows(j).Delete End If Next End With MsgBox "データの転記が終わりました" End Sub

  • ExcelにおけるVBAで、データの振り分けをしたい

    Sub a() Dim i As Long Dim s As Long Dim b As Worksheet Dim c As Worksheet Dim maxi As Long Dim maxs As Long Application.ScreenUpdating = False With ThisWorkbook Set b = .Worksheets("bbb") Set c = .Worksheets("ccc") End With maxi = b.Range("A1").CurrentRegion.Rows.Count maxs = c.Range("A1").CurrentRegion.Rows.Count For i = maxi To 2 Step -1 For s = maxs To 2 Step -1 If c.Cells(s, 1) = b.Cells(i, 1) And c.Cells(s, 2) = b.Cells(i, 2) Then c.Cells(s, 14) = b.Cells(i, 3) End If Next s Next i Application.ScreenUpdating = True End Sub ワークシートcとワークシートbの1列目と2列目が一致したときにだけ、cの14列目にbの3列目のデータを代入したく思い、以上のようなコードを書きましたが、重くて終わる様子がありません。 ・そもそもあっているのか、あっていないならどこを修正すればよいか ・早く終わるようにするにはどうしたらいいか アドバイスをよろしくお願いします。

  • エクセルマクロ 検索して値を取得

    マクロはよく分かっていません。 既存のVBAを見ながらマネしてる状態なので、どこが間違っているのか教えて下さい。 sheet1 A 所属 1 789         2     3 sheet2    A     B 所属コード  所属 1 12345    あいう123 2 12346    あいう456   3 12347    あいう789 やりたいこと シート1の所属が「789」だったらとシート2の所属から「あいう789」を検索し、シート2の所属コード「12347」をシート1の所属に返す。 私が作ったやつだと「12347」は1行目でなく、3行目に返ってしまいます。 Dim SyozokuRange as Range Dim Syozoku as String Dim Buf as String Buf = "あいう" Syozoku = Buf & Syozoku Set SyozokuRange = worksheets(2).range("a:b").currentregion For i = 1 to SyozokuRange.rows.count If Syozoku = SyozokuRange.cells(i,2) Then worksheets(1).cells(i,1).value = SyozokuRange.cells(i,1) end if next i

  • エクセルマクロで教えてください

    Sub smp05_14_01() Dim 対象セル As Range Dim ws1 As Worksheet Dim ws2 As Worksheet Dim ws3 As Worksheet Dim 行 As Long, 列 As Long Dim i As Long Set ws1 = Worksheets("顧客") Set ws2 = Worksheets("売上") Set ws3 = Worksheets("顧客未登録") 行 = ws1.Range("A1").End(xlDown).Row - 1 列 = ws1.Range("A1").End(xlToRight).Column Set 対象セル = ws1.Cells(1, 列 + 2).Resize(2, 行) For i = 1 To 行 対象セル(1, i).Value = "顧客NO" 対象セル(2, i).Value = "<>" & ws1.Cells(i + 1, 1) Next ws2.Range("A1").CurrentRegion.AdvancedFilter _ Action:=xlFilterCopy, _ CriteriaRange:=対象セル, _ CopyToRange:=ws3.Range("A1") 対象セル.Clear End Sub 上記のマクロは売上のシートに登録されている以外の顧客NOを顧客シートを参照して顧客未登録シートにコピーするのもですが添付したファイルの数だと上手くいくのですが、エクセルのヨコのセルの最大値の258を越えると上手くいきません。上記の処理で1000レコードを越えても売上シートに登録されている以外の顧客NOを参照して顧客未登録シートにコピーするマクロを教えてください。

  • エクセルで型番ごとにワークシートをマクロで作る方法

    昨日に質問させて頂いたものですが、下記のマクロを教えて頂いたのですが 新しく生成された型番のワークシートが抜けていたり、最後まで型番が生成されない状態です。 なにか間違っていたら直して頂ける方お願いします。 Sub macro4()  Dim h As Range  Dim w As Worksheet  Dim i As Long, e As Long  Application.ScreenUpdating = False  Application.CutCopyMode = False ’準備  Set w = ActiveSheet  w.Range("4:4").Insert shift:=xlShiftDown  e = Range("B65536").End(xlUp).Offset(1).Row  Range("B4").Select ’複写  Do   ActiveSheet.Copy after:=ActiveSheet   Selection.EntireRow.Delete shift:=xlShiftUp  Loop Until ActiveCell.Offset(1) = "" ’片付け  For i = ActiveSheet.Index To w.Index + 1 Step -1  With Worksheets(i)  .Range(.Range("B4").Offset(1), .Cells(e, "B")).EntireRow.Delete shift:=xlShiftUp  End With  Next i  w.Rows(4).Delete  Application.ScreenUpdating = True End Sub http://okwave.jp/qa/q7081084.html

  • VBAで2つのBOOKのセル範囲を比較

    異なるBOOKのセル範囲のデータを照らし合わせ、不一致があるか確認したいのです。 その際、セル範囲をあらかじめVBAで決め打ちするのではなく、画面上で選択したいので、Application.Inputboxを使おうと思います。 以下のコードで一応はできたのですが、これを使うためには、画面を分割して2つのBOOKの該当箇所を「並べて比較」で並べて表示させておかなければ片方のシートしか選択することができません。 選択範囲が小さい場合は並べて表示させても問題ないのですが、かなり大きな範囲を選択する場合は、並べて表示で画面が半分にされると選択するのが大変です。 まず比較元シートを画面全体に表示して範囲選択し、次に比較先を表示して選択できるようにする方法があばとても作業が楽になります。 ご教示いただければ幸いです。 Sub 選択範囲データ比較() '2019/05/16   Dim myV, myW   Dim buf(1) As Range   Dim i As Long, m As Long, j As Long      Set buf(0) = Application.InputBox(Prompt:="セルを選択してください。", Type:=8)   myV = buf(0).Value   Set buf(1) = Application.InputBox(Prompt:="比較するセルを選択してください。", Type:=8)   myW = buf(1).Value   If UBound(myV, 1) <> UBound(myW, 1) Then     MsgBox "配列 1次元要素数が異なります。", vbCritical     Exit Sub   End If   If UBound(myV, 2) <> UBound(myW, 2) Then     MsgBox "配列 2次元要素数が異なります。", vbCritical     Exit Sub   End If   For i = LBound(myV, 1) To UBound(myW, 1)     For n = LBound(myV, 2) To UBound(myW, 2)       If myV(i, n) <> myW(i, n) Then         j = j + 1       End If     Next n   Next i   If j > 0 Then     MsgBox j & "個、相違があります。", vbCritical   Else     MsgBox "同一です。" _     & vbCrLf & "" _     & vbCrLf & "1次元:" & UBound(myV, 1) & "個" _     & vbCrLf & "2次元:" & UBound(myV, 2) & "個"   End If End Sub

専門家に質問してみよう