- ベストアンサー
マクロLOOP文を別方法で高速化
yuzamasa1101の回答
- yuzamasa1101
- ベストアンサー率0% (0/1)
Application.ScreenUpdating = False は入れていますか？
noname#140971
関連するQ&A
- excel VBAの検索マクロを、OOo CALCで動かしたいのですが
excel VBAの検索マクロを、OOo CALCで動かしたいのですが、、、 お助けください。VBA素人で、OOo BASICは全くわからない者です。よろしくおねがいします。 シート1を検索データの入力及び検索結果の表示画面として使い、 シート2に検索先のデータが入力されています。 検索先のデータは乱雑に入力されており、探したいデータが複数の列に点在し、 かつ、ひとつのセルにふたつのデータが入っていることもあります。 部分一致検索で、EXCELの検索機能の「次を検索」ボタンと同じ機能を果たすように作ったつもりです。 データが見つかった場合、シート2のデータをシート1にコピーするようになっています。 ソフトウェアのバージョンはcalc2.0と3.0です。 Excelでは動いているのですが、どう変えればcalcで使えるようになりますでしょうか？ --------------------------------------------- Sub kensaku() 'sheet1のC4に検索したいデータを入力済 Dim A Set A = Range("sheet1!C4") Dim B As Range 'シート2を選択。 Sheets("sheet2").Select 'A1:S800の範囲をAの値で検索。 Set B = Range("A1:S800").Find(What:=A, _ after:=ActiveCell, SearchDirection:=xlNext, _ LookAt:=xlPart, MatchCase:=False, _ MatchByte:=False, SearchFormat:=False) '分岐 '見つからなかった場合、シート1の関数参照先のセルをクリアしてリセット。 If B Is Nothing Then MsgBox "見つかりません" Sheets("sheet1").Select Range("C2").ClearContents '見つかった場合、処理を続行する。 Else B.Activate 'A列へ移動。場合により空白セルを超える必要があるため10回繰り返す。 Selection.End(xlToLeft).Select Selection.End(xlToLeft).Select Selection.End(xlToLeft).Select Selection.End(xlToLeft).Select Selection.End(xlToLeft).Select Selection.End(xlToLeft).Select Selection.End(xlToLeft).Select Selection.End(xlToLeft).Select Selection.End(xlToLeft).Select Selection.End(xlToLeft).Select 'A列からC列へ移動すると目的のデータが入った列に到達。 Selection.Offset(0, 2).Select 'その値をコピーしてシート1のC2へ貼付(関数の参照先) Selection.Copy Sheets("sheet1").Select Range("C2").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _ SkipBlanks:=False, Transpose:=False '範囲選択を解除 Application.CutCopyMode = False 'sheet2のアクティブセルを次の検索開始位置（16列右）へ移動 (条件に一致する次のデータを検索するため) Sheets("sheet2").Select Selection.Offset(0, 16).Select 'シート1に戻る Sheets("sheet1").Select End If End Sub
- ベストアンサー
- Visual Basic
- 至急お願いします。エクセルのマクロに関してです。
かなり至急です＞＜エクセル2010のマクロの質問です。 2つ質問があります。 1つ目です。 以下の一連の作業を1つのマクロで行いたいのですが、どうしたらいいでしょうか？ 現在は、シート1にデータがあります。 (1)選択した3列を、B~D列に移動する (2)B列に含まれるセルのうち、0（空白）でないセル数分だけシートを追加する。 (たとえば、シート1のB14~B18に数字がはいっていたら、シートを5枚追加するという感じです。) (3)B列に含まれるセルのうち、0（空白）でないセル数分に対し、2行ずつ各シートの3・4行目にコピーする。 (たとえば、シート1のB14~B18に数字がはいっていたら、シート2の3・4行にシート1の14・15行のコピーを貼り付け、シート3の3・4行にシート1の15・16行のコピーを貼り付け、シート4の3・4行にシート1の16・17行のコピーの貼り付ける・・・という感じです。) 現在は (1)Sub () Selection.Cut ActiveCell.Columns("A:C").EntireColumn.Select Selection.Cut Columns("B:B").EntireColumn.Select Selection.Insert Shift:=xlToRight End Sub (2) Sub Macro() Dim n As Long For n = 14 To 18 ' Sheets.Add Next End Sub (3) Sub Macro() Dim n As Long For n = 14 To 18 ' Sheets("Sheet1").Rows(n & ":" & n + 1).Copy _ Sheets("Sheet" & n - 252).Range("A3") Next End Sub と別々のマクロに分けてます。 また(2)(3)でみられる For n = 14 To 18 ' の部分の数字は手動でいれてますが、かなり時間をくってしまうので・・・。 2つ目です。 複数ブックに同じ動作をするエクセルのマクロが知りたいです。 現在100ほどブック(Book1~100)を開いていて、100のブックすべてのSheet1のA1のセルに「１」と入れたいのですが、 そのようなマクロはどうくんだらよろしいでしょうか。 ちなみにExcel2007です。 困っているので、お願いします。
- 締切済み
- その他MS Office製品
- エクセルマクロで改ページプレビュー
お世話になります。 Sub 行挿入() For r = 3 To 50 If Len(Cells(r, 2)) = 13 Then Sheets("sheet2").Select Rows("1:55").Select Selection.Copy Rows("56:56").Select Selection.Insert Sheets("sheet1").Select End If Next End Sub というコードを書いたのですが、「End If」の前に（ｒ－１）ページ目として印刷範囲を５５行追加する、というコードを考えたのですがうまくいきません。教えていただけないでしょうか。
- ベストアンサー
- オフィス系ソフト
- マクロ 結合セルへ値のみ貼り付けるにはどうしたらよいでしょうか。
マクロは初心者で、まだまだ勉強しているところです。 シート名「入出金履歴」のデータを顧客コードごとに分かれている別シートへデータを振り分けて貼り付ける、もしくは反映させたいのですが、貼り付け先のセルがシートの都合上、結合セルになっており、下記のマクロだと当然ながらエラーになってしまいます。結合セルをまず、解除してから貼り付けようと思ったのですが、うまくいかず、困っています。 コピー先の結合状態は、7行目から、列A:C、列D：E、列F:H と、3列になるように結合されています。結合されている行の終わりは、A:C（結合されている）列に「合計」の値が入っているセルの行、H列まで、3列になるよう結合されています。 解除する以外に、良い方法があれば是非教えていただきたいです。 よろしくお願いします。 Sub samplea() r1 = ActiveCell.Row r2 = r1 + Selection.Rows.Count - 1 Dim myRange As Range Dim s_no As String For i = r1 To r2 s_no = Cells(i, 2) Range(Cells(i, 4), Cells(i, 9)).Select Selection.Copy Sheets(Format(s_no)).Select Set myRange = Columns("a:c").Find(what:="合計") If myRange Is Nothing Then Debug.Print "Not Fount" Else myRange.Select Selection.End(xlUp).Offset(1, 0).Select Selection.PasteSpecial Paste:=xlValues Application.CutCopyMode = False Sheets("入出金履歴").Select End If Next End Sub
- ベストアンサー
- Visual Basic
- エクセルマクロでオートフィルタを貼り付け。VBA
お世話になっております。 エクセルのマクロを作成したのですが、上手く機能いたしません。 オートフィルタで条件に一致するものが現在表示されている 「CSV元データをここに貼り付ける」という名前のシートが ございます。 これをシートを全選択し、そのまま 「加工1」という名前のシートに貼り付ける。 といったマクロを作成したのですが、加工1には何も貼り付けられていないようです。 下記にマクロのプログラムを記載しますので、どこを訂正すればいいのかをお教えいただければ ありがたいです。 無知で申し訳ございませんが、何卒よろしく御願いいたします。 当方が今したいのは、マクロ2なのですが、マクロ2を見ようとするとマクロ1も表示されます。 なぜ、マクロ1もでてくるのかわかりませんが、よろしく御願いいたします。 Sub マクロ1() ' ' マクロ1 Macro ' マクロ記録日 : 2011/10/31 ユーザー名 : ' ' Columns("A:D").Select Selection.Delete Shift:=xlToLeft Columns("D:D").Select Sheets("読込データ(加工1)").Select ActiveWindow.ScrollColumn = 2 ActiveWindow.ScrollColumn = 1 Sheets("読込データ(ORG)").Select ActiveWindow.ScrollColumn = 2 ActiveWindow.ScrollColumn = 3 ActiveWindow.ScrollColumn = 4 ActiveWindow.ScrollColumn = 6 ActiveWindow.ScrollColumn = 7 ActiveWindow.ScrollColumn = 8 ActiveWindow.ScrollColumn = 10 ActiveWindow.ScrollColumn = 11 Sheets("csv元データをここに貼り付ける").Select Columns("B:D").Select Selection.Delete Shift:=xlToLeft Columns("I:P").Select Selection.Delete Shift:=xlToLeft Range("I19").Select Sheets("csv元データをここに貼り付ける").Select Rows("2:2").Select Selection.AutoFilter Selection.AutoFilter Field:=9, Criteria1:="=2", Operator:=xlAnd End Sub Sub マクロ2() ' ' マクロ2 Macro ' マクロ記録日 : 2011/10/31 ユーザー名 : ' ' Cells.Select Selection.Copy Sheets("加工1").Select Range("G12").Select End Sub
- ベストアンサー
- オフィス系ソフト
- エクセル マクロ：文字変更
教えてください。 sheet5にデータがあります。 マクロを実行すると、一番右の列のセルに○があると●と書き換える 一番右の列のセルに△があると▲と書き換えるコードを作成しています。 下記のコードでは時間がかかってしまいます。 省略 If Sheets("sheet5").Cells(r, cmax).Value = "○" Then Sheets("sheet5").Cells(r, cmax).Value = "●" 省略 AutoFilterを使用してマクロを作成しましたが、列に○と△が両方無いと 範囲指定したセルがすべて▲となってしまいます。 下記コードをどのように手直ししたらよいのか教えて頂けないでしょうか。 よろしくお願いします。 Sub 文字変更() Dim c As Integer Dim cmax As Integer Dim rmax As Long With Sheets("sheet5") rmax = .Range("A3").End(xlDown).Row cmax = .Range("A3").End(xlToRight).Column .Rows("1:1").Select Selection.AutoFilter For c = 2 To cmax Selection.AutoFilter Field:=c, Criteria1:="○" .Cells(1, c).Offset(1, 0).Select .Range(Selection, Cells(rmax, c)).Value = "●" Selection.AutoFilter Field:=c, Criteria1:="△" .Cells(1, c).Offset(1, 0).Select .Range(Selection, Cells(rmax, c)).Value = "▲" Selection.AutoFilter Field:=c Next c End With Selection.AutoFilter End Sub
- ベストアンサー
- オフィス系ソフト
- マクロでVLookupが出来ません。
マクロでVLookupが出来ません。 A列からE列までデータがあるシート1のA,B,C列の値が全て一致する シート2の行削除をしたいです。 2000行中500行残るはずのダミーで実験してますが全行削除されてしまいます。 Do Until Cells(Line, 6).Value →6の部分を1 VLookup(Cells(Line, 6) →6の部分を1にすれば 500行残ります。ですがこれでは検索値がA列のみの値です。 またそれぞれ1→2、1→3、1→4にしても同じく全行消えこんがらがってます。 シート1のA列のみ検索しているような動きです。どこを修正すればいいのでしょうか？ Sub 行削除() 'シート１→8月シート２→9月 Sheets("8月").Select Range("F2").Select ActiveCell.FormulaR1C1 = "=RC[-5]&RC[-4]&RC[-3]" Selection.AutoFill Destination:=Range("F2:F10000") Sheets("9月").Select Range("F2").Select ActiveCell.FormulaR1C1 = "=RC[-5]&RC[-4]&RC[-3]" Selection.AutoFill Destination:=Range("F2:F10000") '検索する対象値があるシート選択 Sheets("9月").Select 'そのシートの検索開始の行数を選択2行目。 Line = 2 'そのシートの検索値の列指定6=F列。セルF2の値が検索したい値。 'その値がなくなったら検索を終了させる.Value = ""を追加。 Do Until Cells(Line, 6).Value = "" 'エラーとなっても次に進む On Error Resume Next '検索結果を記入する列を指定。Line7=G列（※１） '検索する値があるシートとその列を指定 'VLookup(Cells(Line, 6)の部分。6=F列 '検索されるシートと検索範囲を指定 'Worksheets("9月").Range("A2:F10000")→セルA2からセルF10000まで '検索されたらその行のどの列の値を結果とするのか指定 1=A列 '検索方法指定0=FALSE完全一致。 Cells(Line, 7).Value = Application.WorksheetFunction.VLookup(Cells(Line, 6)_ .Value, Worksheets("8月").Range("A2:F10000"), 1, 0) 'VLOOKUP関数が終了又はエラーが発生したら止まる On Error GoTo 0 '検索されなかったときの処理 '上記（※１）の部分Line7=G列に値がない If Cells(Line, 7).Value = "" Then 'Line7=M列に無と表示 Cells(Line, 7).Value = "無" End If '2行目から開始なので次の行の値を検索値とする Line = Line + 1 '検索する値がなくなるまで繰返す Loop '1行目が削除されるのを防止セルG1に無とセット Sheets("9月").Select Range("G1").Select ActiveCell.FormulaR1C1 = "無" 'データの最終行の行番号を保持する変数 Dim RwMax As Long '現在処理中の行番号を保持する変数 Dim Rw As Long '対象となるシートを選択。 Worksheets("9月").Select 'データの最終行の行番号を取得。 'Count, 7=G列 においてデータが入っている一番下のセルの行番号 RwMax = Cells(Rows.Count, 7).End(xlUp).Row '最終行から１行目まで繰返し処理。 '行の削除の為下から上へと処理。 For Rw = RwMax To 1 Step -1 '値が無ならそのまま If Cells(Rw, 7).Value = "無" Then Cells(Rw, 7).Value = "無" '無でなかったら行削除 Else Rows(Rw).Delete End If Next Rw 'シート2のF,G列を列削除 Sheets("9月").Select Columns("F:G").Select Application.CutCopyMode = False Selection.Delete Shift:=xlToLeft End Sub
- ベストアンサー
- オフィス系ソフト
- VBAマクロエラー【オーバーフローしました。】
以下のVBAマクロで突然エラーが出るようになってしまいました。 原因がわからず困っています。 どなたかご教授ください。 該当部分 :S = Range("B2").End(xlDown).Row エラーMrg:実行時エラー'6': オーバーフローしました ----------マクロ文---------- Sub 部担コード読み替え() Dim R_Count As Integer Dim P_Sheet As String Dim S As Integer 'データ取込用のファイルを開く Workbooks(D_Book).Activate Sheets("Data1").Select Columns("C:C").Select Selection.Insert Shift:=xlToRight Range("B2").Select S = Range("B2").End(xlDown).Row Range("C2:C" & S).Formula = "=SUBSTITUTE(SUBSTITUTE(RC[-1],""%"",""1""),""*"",""2"")" Range("C1").Value = "部担コード" Cells.Select Selection.Copy Selection.PasteSpecial Paste:=xlPasteValues Columns("B:B").Select Application.CutCopyMode = False Selection.Delete Shift:=xlToLeft Range("A1").Select Sheets("Data2").Select Columns("C:C").Select Selection.Insert Shift:=xlToRight Range("B2").Select S = Range("B2").End(xlDown).Row Range("C2:C" & S).Formula = "=SUBSTITUTE(SUBSTITUTE(RC[-1],""%"",""1""),""*"",""2"")" Range("C1").Value = "部担コード" Columns("G:G").Select Selection.Insert Shift:=xlToRight Range("G2:G" & S).Formula = "=SUBSTITUTE(SUBSTITUTE(RC[-1],""%"",""1""),""*"",""2"")" Range("G1").Value = "キー" Cells.Select Selection.Copy Selection.PasteSpecial Paste:=xlPasteValues Columns("B:B").Select Application.CutCopyMode = False Selection.Delete Shift:=xlToLeft Columns("E:E").Select Application.CutCopyMode = False Selection.Delete Shift:=xlToLeft Range("A1").Select End Sub
- 締切済み
- Excel（エクセル）
- 条件にて行削除をするをマクロで高速化したい
シート（最初）のA,B,C列を連結した値と シート（残）のA,B,C列を連結した値を照合させ 同じ値の場合は シート（残）の該当行を削除です。 シート（最初）は6,182行 シート（残）は7,561行です。 VLookupを使って処理時間5分です。 VLookupを使わない記述で25分です。 20,000行位のデータを処理したいのですが時間が不安です。 別スレで 「VLookupで処理3分をdictionaryオブジェクトで1秒以内にする方法」を 教えていただきましたが、流用ができません。 シート（残）内にもシート（最初）内にも重複行はありません。 私の記述は「F列を検索用に使用」となっていて F列にデータがある場合、都度記述を書換えないと 使えないので、そこも対応したいです。 照合させる値はA,B,Cの連結値というのは変わらないのですが データがある範囲は都度変化する為です。 ・A～E列とかA～H列とか ・シート残はA～E列、シート最初はA～G列とか 記述そのものを教えてください。よろしくお願いします。 Sub 自動重複削除F列使用() 'シート（最初）のA,B,C列とシート（残）のA,B,C列が一致した行は 'シート残の行を削除 'F列を検索値として使用。 Dim Line As Long Dim LastRow As Long Dim myRange As Range Dim Flag 'シート「最初」のF1に、A,B,C列を結合した値を転記 With Sheets("最初") Set myRange = .Range("F2:F" & .Cells(Rows.Count, "A").End(xlUp).Row) .Range("F2").FormulaR1C1 = "=RC[-5]&RC[-4]&RC[-3]" 'シート「最初」のF2からデータのあるところまで 'F1の規則でデータ貼付 .Range("F2").AutoFill Destination:=myRange End With 'シート「残」のF1に、A,B,C列を結合した値を転記 Sheets("残").Select LastRow = Cells(Rows.Count, "A").End(xlUp).Row Range("F2").FormulaR1C1 = "=RC[-5]&RC[-4]&RC[-3]" 'シート「最初」のF2からデータのあるところまで 'F1の規則でデータ貼付 Range("F2").AutoFill Destination:=Range("F2:F" & LastRow) On Error Resume Next '双方のシートのF列を照合させ、ヒットした行は 'シート「残」から行削除をする For Line = LastRow To 2 Step -1 Flag = WorksheetFunction.VLookup(Cells(Line, 6).Value, myRange, 1, 0) If Err.Number = 0 Then Rows(Line).Delete xlUp Else Err.Clear End If Next Line '検索に使用したＦ列を削除 Sheets("残").Select Columns("F:F").Select Selection.Delete Shift:=xlToLeft Sheets("最初").Select Columns("F:F").Select Selection.Delete Shift:=xlToLeft Sheets("残").Select Range("A1").Select End Sub ●別方法 Sub 自動重複行削除F列未使用超遅() 'VLOOKUP無 'シート（最初）のA,B,C列とシート（残）の 'A,B,C列が一致した行はシート（残）の行を削除 Dim ws1, ws2 As Worksheet Dim i, j As Long Set ws1 = Worksheets("最初") Set ws2 = Worksheets("残") For i = 2 To ws1.Cells(Rows.Count, 1).End(xlUp).Row For j = ws2.Cells(Rows.Count, 1).End(xlUp).Row To 2 Step -1 If ws1.Cells(i, 1) = ws2.Cells(j, 1) And ws1.Cells(i, 2) = ws2.Cells(j, 2) And _ ws1.Cells(i, 3) = ws2.Cells(j, 3) Then ws2.Rows(j).Delete (xlUp) End
- ベストアンサー
- オフィス系ソフト
- マクロで教えてください。
sheet1のA列にある図番を参照しsheet2のA列の機種名に適合する行全体に sheet1のB列にある色を塗りたいのですが、マクロを教えていただけますでしょうか？ sheet2のBのセル色を塗るマクロはわかりました。↓です。 Sub macro1() Dim c As Range, myR As Variant With Sheets("Sheet2") For Each c In .Range("a2", .Cells(Rows.Count, "a").End(xlUp)) myR = Application.Match(c.Value, Sheets("sheet1").Columns(1), 0) If Not IsError(myR) Then c.Offset(, 1).Interior.ColorIndex = Sheets("sheet1").Cells(myR, "B").Interior.ColorIndex End If Next End With End Sub 上記マクロですとBセルのみ色が塗られてしまうので行全体を塗るマクロを教えてください。 よろしくお願い致します。
- ベストアンサー
- オフィス系ソフト
お礼
入れてみましたが、あまり変化はありませんでした。 どうもありがとうございました。