• 締切済み
  • すぐに回答を!

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列目のデータを代入したく思い、以上のようなコードを書きましたが、重くて終わる様子がありません。 ・そもそもあっているのか、あっていないならどこを修正すればよいか ・早く終わるようにするにはどうしたらいいか アドバイスをよろしくお願いします。

共感・応援の気持ちを伝えよう!

  • 回答数2
  • 閲覧数274
  • ありがとう数1

みんなの回答

  • 回答No.2

プロパティを設定することでの処理の高速化を紹介します。 自動で計算を行わないようにする。 Application.Calculation = xlCalculationManual 解除 Application.Calculation = xlCalculationAutomatic イベントがあがらないようにする。 Application.EnableEvents = False 解除 Application.EnableEvents = True 画面の更新を行わない設定をする、Application.ScreenUpdatingと同じイメージです。 試してみてください。 #1さんのおっしゃること(.VALUE)、と上記を加えることで、 回答者の実行環境ではありますが、処理が2倍程度早くなりました。

共感・感謝の気持ちを伝えよう!

関連するQ&A

  • 2枚のエクセルのシートを図のように統合させる

    2枚のエクセルのシートを統合させるやり方を教えて下さい。 (同じ項目に2人の人が答えている場合2行に分けることはできますか。) 以前こちらで質問させていただいたとき、 Sub test() Dim Sh1 As Worksheet Dim Sh2 As Worksheet Dim Sh3 As Worksheet Set Sh1 = Workbooks("book1.xls").Sheets("Sheet1") Set Sh2 = Workbooks("book2.xls").Sheets("Sheet1") Set Sh3 = Workbooks("book3.xls").Sheets("Sheet1") Sh1.Range("B5").CurrentRegion.Copy Sh3.Range("B5") With Sh2.Range("B5").CurrentRegion .Resize(.Rows.Count - 1).Offset(1).Copy Sh3.Cells(Sh3.Rows.Count, "B").End(xlUp).Offset(1) End With With Sh3 Dim r As Long For r = .Cells(.Rows.Count, "B").End(xlUp).Row To 6 Step -1 If .Cells(r, "C").Value = "" Then .Rows(r).Delete Next r .Range("B5").CurrentRegion.Sort Key1:=.Range("B6"), Order1:=xlAscending, Header:=xlYes For r = .Cells(.Rows.Count, "B").End(xlUp).Row To 6 Step -1 If .Cells(r, "B").Value = .Cells(r - 1, "B").Value Then .Cells(r, "B").ClearContents Next r End With End Sub というコードを教えていただいたのですが、項目の中があいうえお順になってしまいうまくいきません。 そして、途中に項目があったりしてこれは1つだけ表示されるようにできますか? 説明が足りないところは、補足いたします。 いきなり部署を異動させられて今までやったことないようなことをやっています(涙) どなたか教えて下さいよろしくお願いします。

  • 【Excel VBA】データ貼り付けの開始位置について

    Excel2003を使用しています。 先日、こちらでアドバイスをいただきながら、下記のようなマクロを作りました。内容はあるセルの値と同じ名前のシートへデータをコピーするというものです。 Sheet1に貼り付け元のデータが表形式であり、必要なデータのみ該当のシートへコピーします。マクロ実行後は、別の新しいデータをSheet1へコピペして、またマクロを実行するのですが、その際、データの貼り付け開始位置を前回マクロを実行して貼り付けられたデータから2行空けたいのですが、可能でしょうか? ________________________________________________________________________________________________________________________________ Sub test3() Dim n As Long Dim i As Long Dim j As Long  Worksheets("Sheet1").Activate   For n = 4 To Cells(Rows.Count, 2).End(xlUp).Row    If Cells(n, 3).Value <> "" Then     With Worksheets(CStr(Cells(n, 3).Value))       i = .Cells(Rows.Count, 3).End(xlUp).Row + 1       Cells(n, 2).Copy .Cells(i, 2)       Cells(n, 7).Resize(, 2).Copy .Cells(i, 4)       Cells(n, 11).Copy .Cells(i, 3)     End With    End If    If Cells(n, 13).Value <> "" Then     With Worksheets(CStr(Cells(n, 13).Value))       j = .Cells(Rows.Count, 3).End(xlUp).Row + 1       Cells(n, 12).Copy .Cells(j, 2)       Cells(n, 17).Copy .Cells(j, 4)       Cells(n, 18).Copy .Cells(j, 6)       Cells(n, 11).Copy .Cells(j, 3)     End With    End If   Next n End Sub

  • EXCEL2010エラーVBA

    下記を実行するとエラーになりEXCEL2010が終了してしまいます。 fDebug:0 offset00009391 がエラーメッセージです。 何が原因でしょうか。 Private Sub Worksheet_Change(ByVal Target As Range) Dim ws As Worksheet Dim rg As Range Dim r As Variant Dim c As Long Dim hanni1 As Range Dim atai As Range Set ws = Worksheets("あああ") Set rg = Worksheets("コード").Range("A1:B10") r = ws.Cells(Rows.Count, 1).End(xlUp).Row Set hanni1 = ws.Range(Cells(2, 2), Cells(r, 3)) Set atai = ws.Range(Cells(2, 3), Cells(r, 3)) atai = Application.VLookup(hanni1, rg, 2, False) End Sub

  • 回答No.1

こんばんは ・そもそもあっているのか、あっていないならどこを修正すればよいか こうしたことを切り分けるためには、 Application.ScreenUpdating = False Application.ScreenUpdating = True をコメントアウトして、ブレークポイントをかけてステップ実行し、動きを追うのがいいですよ。 で、プログラムなんですが、 ・Bのシートを1行ずつ後ろからみながら、Cのシートを1行ずつ後ろから見ていますよね。これはイメージとあっていますか? ・データだけを比較したいなら c.Cells(s, 1).Value = b.Cells(i, 1).Value And c.Cells(s, 2).Value = b.Cells(i, 2).Value の方が早いと思います。代入も c.Cells(s, 14).Value = b.Cells(i, 3).Valueの方がたぶん早い。 ・Bのシートの後ろの方で、Cのシートのデータと一致するものがあった時、さらにBのシートの前の方で、Cのシートのデータと一致するものがあった場合には、Cの14列目の値が上書きされますが、これを意図していますか?それとも2回以上一致することがないという前提でしょうか?あるいは複数回一致したら、Bのシートの前の方の値を使用するという仕様なんでしょうか?・・・・・仮に最後の問いにYESであれば、外側のループをCのシートにして、内側のループをBのシートにして i = 2 To maxi Step 1 にした上、代入直後にExit Forを入れれば、Bのシートの残りの検索を行わなくなり高速になります。 ほかにもC,Bのワークシートに一時的に(1列目と2列目を=":"&1列目&":"&2列目&":"と式を入れた列)を挿入してVLOOKUPで探すとかも考えられそうです。 実際のデータ(のイメージだけでも)もわかれば、より効率の良い方法が教えてもらえると思いますよ。

共感・感謝の気持ちを伝えよう!

関連するQ&A

  • VBAで削除を早くしたいのですが…

    Excel2007のVBAです。キー記録を眺めながら四苦八苦しております。 数千行あるデータで、A列が"d"以外の行を削除したいのですが PCスペックが低いせいか、時間がかかってしまいます。 簡単に効率化することは可能でしょうか? よろしくお願いします。 ※1行目はタイトル列、全体行数は可変です。 Sub A05_A列がd以外は削除する() Application.ScreenUpdating = False Dim sh2 As Worksheet Set sh2 = Worksheets("削list") For i = Cells(Rows.Count, "C").End(xlUp).Row To 2 Step -1 If sh2.Cells(i, "A").Value <> "d" Then Rows(i).Delete End If Next Application.ScreenUpdating = True End Sub

  • VBA AutoFilter 範囲指定

    いつもお世話になっております 過去に https://okwave.jp/qa/q9707059.html にてワークシートのデータをオートフィルターをかけて別なワークシートにデータを取り出す方法を教えて頂きました 送られてくる元データが変更になって、A3セルの上のA2セルの上にテキスト文字が入るようになったので、範囲指定を正しく出来るようにする方法を https://okwave.jp/qa/q9708868.html にて教えて頂きました 今回、https://okwave.jp/qa/q9707059.htmlで教えて頂いたワークシートのコードを実行させると元データが変更になったデータを利用すると、A1セルまで含まれた範囲がAutoFilter の領域と判断される為正しい結果となりません 添付画像のワークシートで Sub test9() Worksheets("Sheet1").Range(Cells(3, "A"), Cells(Range("A3").CurrentRegion.Rows.Count, Range("A3").CurrentRegion.Columns.Count)) _ .AutoFilter Field:=2, Criteria1:=Cells(5, "G").Value End Sub を実行させれば、"秋田”でフィルターがきちんとかけれらた状態になります そこで教えて頂いたコードを下記に変更して実行させてみたのですが Dim i As Long With Worksheets("Sheet1") .Range("B4", .Range("B4").End(xlDown)).Copy .Range("G4").PasteSpecial (xlPasteAll) .Range("G4", .Range("G4").End(xlDown)).RemoveDuplicates Columns:=Array(1), Header:=xlNo For i = 4 To .Cells(Rows.Count, "G").End(xlUp).Row Worksheets.Add After:=Worksheets(Worksheets.Count) ActiveSheet.Name = .Cells(i, "G").Value .Range(Cells(3, "A"), Cells(Range("A3").CurrentRegion.Rows.Count, Range("A3").CurrentRegion.Columns.Count)) _ .AutoFilter Field:=2, Criteria1:=.Cells(i, "G").Value .Cells(3, 1).CurrentRegion.Copy Destination:=Worksheets(.Cells(i, "G").Value).Cells(3, 1) .AutoFilterMode = False Next .Range(Cells(3, "A"), Cells(Range("A3").CurrentRegion.Rows.Count, Range("A3").CurrentRegion.Columns.Count)) _ .AutoFilter Field:=2, Criteria1:=.Cells(i, "G").Value 部分で 実行時エラー'1004' アプリケーション定義またはオブジェクト定義のエラーです になってしまいます 元データがA2セルにテキスト文字が入った状態でも正常にコード動作させるにはどのようにしたらいいのでしょうか よろしくお願い致します

  • VBA 同じ場所に保存する

    部署ごとに分割し、ブックで保存するコードです。 保存場所がデスクトップになっています。 これを同じ場所に保存する方法をお知らせください。 よろしくお願いします。 Sub macro1() Dim w As Worksheet Dim n As Long Dim r As Long Dim s As String Dim WSH As Variant Dim myPath As String Set w = ActiveSheet n = Worksheets.Count Application.ScreenUpdating = False On Error GoTo errhandle For r = 2 To w.Range("A65536").End(xlUp).Row s = w.Cells(r, "A") w.Rows(r).Copy Worksheets(s).Range("A65536").End(xlUp).Offset(1) Next r On Error GoTo 0 Set WSH = CreateObject("Wscript.Shell") myPath = WSH.specialfolders("Desktop") & "\" For r = Worksheets.Count To n + 1 Step -1 Worksheets(Worksheets.Count).Copy ActiveSheet.Columns.AutoFit ActiveWorkbook.SaveAs Filename:=myPath & ActiveSheet.Name ActiveWorkbook.Close False Application.DisplayAlerts = False Worksheets(Worksheets.Count).Delete Application.DisplayAlerts = True Next r w.Select Exit Sub errhandle: Worksheets.Add after:=Worksheets(Worksheets.Count) ActiveSheet.Name = s w.Rows(1).Copy Range("A1") Resume Application.ScreenUpdating = True End Sub

  • エクセル:マクロの手直し

    お世話になります。 以前ここで教えてもらったマクロのシート名のつけ方をすこし手直ししたいのでアドバイスください。 以下のマクロは、1シート目を決まった行数分に分割し各シートに振り分けるものです。今のマクロではシート名は分割1、分割2…分割10…などなりますが、Worksheets(1) のシート名+3桁の連番(001,002…010…)などとしたい。 Worksheets(1) のシート名が「総務課」の場合、総務課001,総務課002…総務課010…となるのが理想です。 このようにするためにはマクロをどのように修正すればよいか教えてください。 Sub シート分割()  Dim WS1 As Worksheet  Dim WS2 As Worksheet  Dim i As Integer  Dim Bunkatsu As Integer  Set WS1 = Worksheets(1) 'コピー元のデータシート  Set WS2 = WS1  Bunkatsu = 1  Application.ScreenUpdating = False  For i = 7 To WS1.Cells(Rows.Count, 1).End(xlUp).Row Step 25   Set WS2 = Worksheets.Add(After:=WS2)   WS2.Name = "分割" & Bunkatsu   WS1.Rows("1:6").Copy WS2.Cells(1, 1)   WS1.Rows(i & ":" & i + 24).Copy WS2.Cells(7, 1)   Bunkatsu = Bunkatsu + 1  Next  Application.ScreenUpdating = True End Sub

  • VBA 変数について

    下記コードにおける変数rは、具体的にどういう事を意味するのでしょうか? よろしくお願いします。 Dim r As Long With Worksheets("Steet1") r=.Cells(.Rows.Count,"a").End(xlUp).Row

  • 12か月分の日付データを繰返し記入したい

    下記動作を実現したくマクロを書いてみましたが、正常に処理できません。 修正が必要な箇所&修正方針について、知識のある方からご助言いただけますと幸いです。。 <実現したいこと> ・sh2のV列(2行目&#65374;)に対し、 2019/4/1 2019/5/1 … 2020/3/1 と12行書き込む処理を、(sh1の2&#65374;最終行)回行う ※最終的に、sh2のV列は、先頭行の下に、(sh1の2&#65374;最終行)×12行できる想定 <正常に動かなかった記述> Sub V列の処理() Dim sh1 As Worksheet, sh2 As Worksheet Dim r As Long, i As Long Application.ScreenUpdating = False Set sh1 = Worksheets("元シート") Set sh2 = Worksheets("集計用シート") '2から最終行まで12行おきの繰り返しです For r = 2 To sh1.Cells(Rows.Count, 1).End(xlDown).Row Step 12 'まず、V列の各1行目に4月の値を入れます sh2.Cells(r, 22) = "2019/4/1" 'したら、12か月分入れていきます For i = 1 To 11 sh2.Cells(r + i, 22) = DateAdd("m", i, Cells(r, 22)) Next i Next r Application.ScreenUpdating = True End Sub

  • データ抜き出しマクロについて

    以下のプログラムは10行ごとにデータを抜き出すプログラムです。 これに追加して例えば5結果の変動があったとき、10%結果の変動が あった時にデータを抜き出すようにするにはどうすればいいですか? Sub nukitori() Dim X As Worksheet Dim i As Long Dim ii As Long Dim col As Integer Dim Nukitori_Step As Long Nukitori_Step = 10 i = 2 ii = 2 '●●●見出し行が1行目なので2で始める Set X = ActiveSheet '●シートShordataがあったら削除 On Error Resume Next Application.DisplayAlerts = False Worksheets("shortdata").Delete Application.DisplayAlerts = True On Error GoTo 0 Worksheets.Add.Name = "shortdata" '●先ず、見出しをコピー Worksheets("shortdata").Rows(1).Value = X.Rows(1).Value While X.Cells(i, 1) <> "" And i < 65535 For col = 1 To 255 Worksheets("shortdata").Cells(ii, col).Value = X.Cells(i, col).Value Next If i = 2 Then i = 1 i = i + Nukitori_Step ii = ii + 1 Wend End Sub

  • VBA 任意のシートからコピーを始める。

    教えてください。 全てのシートをコピーして一つのシートにまとめるプログラムシートを作成しました。 1番目のシートからコピーを始める場合は For i = 2 To Worksheets.Count 2番目のシートからコピーを始める場合は For i = 3 To Worksheets.Count とすればよいのですがこれだといちいちモジュールコードを出して数字を変更しなければならず面倒です。 そこでユーザーフォームのコンボボックスに任意の数字を入れてクリックを押せば希望するシートからコピーを始めるプログラムを作成してみましたがうまくいきません。どなたか教えてくださいませんか。 Sub matome() Dim i As Integer Dim lRow As Long, lCol As Long, lRow2 As Long, lRow3 As Long, SNo As Integer '----何番目からコピーを始めるかを決定します With UserForm2 SNo = .ComboBox1.value End With For i = 1 + SNo To Worksheets.Count With Worksheets(i) lRow = .Cells(Rows.Count, 1).End(xlUp).Row + 1 lCol = .Cells(1, Columns.Count).End(xlToLeft).Column '----シートのデータが2行以上の場合にコピーします If lRow >= 2 Then lRow2 = Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Row + 1 If lRow2 < Worksheets(1).Cells(Rows.Count, 5).End(xlUp).Row + 1 Then lRow2 = Worksheets(1).Cells(Rows.Count, 5).End(xlUp).Row + 1 .Activate .Range(Cells(2, 1), Cells(lRow, lCol)).Copy Worksheets(1).Cells(lRow2, 1) End If End With Next i

  • エクセル重複行統合マクロの意味

    Tom04さんの回答で 以下のとても素晴らしいマクロがあり、 使用させていただきたいのですが、 詳細がわかりません。 少々編集して自分の書類に反映させていただきたく、 マクロの内容を教えていただけませんか? Sub test() 'この行から Dim i, j, k, L As Long Application.ScreenUpdating = False For i = Cells(Rows.Count, 1).End(xlUp).Row To 2 Step -1 For j = 2 To Cells(1, Columns.Count).End(xlToLeft).Column + 1 For k = Cells(Rows.Count, j).End(xlUp).Row To 2 Step -1 If Cells(k, j) <> "" And WorksheetFunction.CountIf _ (Range(Cells(2, 1), Cells(k, 1)), Cells(k, 1)) > 1 Then L = WorksheetFunction.Match(Cells(k, 1), Columns(1), False) Cells(k, j).Cut Destination:=Cells(L, j) End If Next k Next j Next i For i = Cells(Rows.Count, 1).End(xlUp).Row To 2 Step -1 If WorksheetFunction.CountA(Rows(i)) = 1 Then Rows(i).ClearContents End If Next i Application.ScreenUpdating = True End Sub 'この行まで

  • VBA 高速化

    以下のコードを改良して早く処理できるようにしたいです。素因数分解をして、素因数の数を数えるプログラムです。 Sub 素因数を数える() Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Dim I As Long, j As Long, cnt As Long, wS As Worksheet, k As Long, Set wS = Worksheets("Sheet2") k = Worksheets("Sheet1").Range("A100010").End(xlUp).Row - 1 For dd = 3 To k Call aaa(Range("A" & dd)) Next dd Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic End Sub Private Sub aaa(ByVal Target As Range) Set wS = Worksheets("Sheet2") If Intersect(Target, Range("A:A")) Is Nothing Or Target.Count > 1 Then Exit Sub With Target If Not IsNumeric(.Value) Then Exit Sub If .Value Mod 1 = 0 Then Range("D1") = .Value For I = 1 To wS.Cells(Rows.Count, "A").End(xlUp).Row Do While Cells(Rows.Count, "D").End(xlUp) Mod wS.Cells(I, 1) = 0 cnt = cnt + 1 Cells(Rows.Count, "D").End(xlUp).Offset(1) = Cells(Rows.Count, "D").End(xlUp) / wS.Cells(I, 1) Loop If Cells(Rows.Count, "D").End(xlUp) = 1 Then Exit For Next I End If .Offset(, 1) = cnt End With Range("D:D").Clear End Sub 以前教えていただいたコードを使って書きました。 どういう状況で使っているかといいますと、シート1のA列に自然数を2から順番に並べ、シート2のA列に素数を並べておき、プログラムを実行すると、B列に素数の数が表示されるという具合です。 大変役に立っていたのですが、10萬ほどのデータを扱おうとすると、自分のコンピュータでは時間がかかりすぎます。そこでコードを改良して高速化をしたいのです。 いま考えられる改良点は、 1、D列を使って行っている処理をメモリで行うようにして、セルへのアクセスを省けないか 2、aaaの5行目の、"wS.Cells(Rows.Count, "A").End(xlUp).Row"この処理を簡単な変数の処理で代用できないか ということです。他にも高速化できる方法があれば教えてください。 よろしくお願いします。