VBAで転記すると#REF!に

このQ&Aのポイント
  • VBAで転記すると#REF!になってしまう現象が発生しています。
  • マクロで請求書から売上表にデータを転記する際に、5行が反転しながらエラーが発生します。
  • 考えられる原因は、マクロのコードやH列の数式に不都合がある可能性があります。
回答を見る
  • ベストアンサー

VBAで転記すると#REF!に

いつもお世話になります。 WINDOWS7 EXCELL2010 です。 現在、請求書から売上表にマクロにて転記するファイルを作成中です。 添付図の上の画像でH列に数式を入れるまでは画像の下のようにマクロで入力するごとに5行が反転(範囲を選択したような)しながらもエラーなく入力できていました。 H列に数式を入れたときは画像の上でした。 ところがテストで請求書よりマクロにて入力すると画像の下のようにA10:G14で5行が反転してエラーが発生します。 マクロにて請求書から売上表に入力した時は必ずこの5行の反転が生じます。 私なりの見解ですがこの5行の反転がなにか悪戯しているのではないかと考えます。 下記にマクロとH列の数式を掲載します。 何か不都合または具合が悪いところがあるのでしょうか。 是非是非御指導いただけませんでしょうか。 Sub 売上表転記1() Dim i As Long, wS As Worksheet Set wS = Worksheets("売上表") Worksheets("納請書1").Range("L5:R9").Copy wS.Cells(Rows.Count, "A").End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues '★ Application.CutCopyMode = False For i = wS.Cells(Rows.Count, "A").End(xlUp).Row To 2 Step -1 '★ If WorksheetFunction.CountIf(wS.Cells(i, "A").Resize(, 4), "") = 4 Then wS.Cells(i, "A").Resize(, 4).Delete shift:=xlUp End If Next i End Sub 参考にH2 =IF(MONTH(A2)=MONTH(A3),"",SUMPRODUCT((MONTH(OFFSET($A$2,0,0,COUNT(A:A)))=MONTH(A2))*OFFSET($E$2,0,0,COUNT(A:A))))

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

  • ベストアンサー
  • tom04
  • ベストアンサー率49% (2537/5117)
回答No.2

No.1です。 補足を拝見しました。 結局「行削除」が他の列にも影響しているみたいですね。 前の質問が単にL5~O9セルの空白以外をコピー&ペーストだったので 数式によって空白になっているセルを後から削除するようにしたためにこのような問題が起きていると思われます。 根本的に変えた方が良いみたいなので、 ↓のコードにしてみてください。 Sub 転記() Dim i As Long, wS As Worksheet Set wS = Worksheets("売上表") With Worksheets("納請書1") For i = 5 To 9 '★5~9行までループ If .Cells(i, "L") <> "" Then .Cells(i, "L").Resize(, 4).Copy wS.Cells(Rows.Count, "A").End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues End If Next i Application.CutCopyMode = False End With End Sub ※ 単純に「納請書1」シートのL列5行目から9行目までループさせ L列が空白以外のデータを「売上表」シートのA列最終行以降にコピー&ペーストしています。 これではどうでしょうか?m(_ _)m

dorasuke
質問者

お礼

おはようございます。 大変ご苦労をお掛けしました。 上手くできて今は感謝感激です。 やったぁ~という気持です。 本当にありがとうございました。 これに懲りずに今後ともよろしくお願いいたします。

その他の回答 (1)

  • tom04
  • ベストアンサー率49% (2537/5117)
回答No.1

こんばんは! ↓のサイトの関連質問ですね。 http://okwave.jp/qa/q8832489.html 前回回答した責任があると思いますので、投稿します。 セルを削除すると参照するセルがなくなってしまうために起こるエラーだと思います。 そこで手っ取り早く、数式を入れ直してみてはどうでしょうか? それをマクロで行います。 ↓のコードにしてみてください。 Sub 売上表転記1() Dim i As Long, lastRow As Long, wS As Worksheet '★変数を追加 Set wS = Worksheets("売上表") Worksheets("納請書1").Range("L5:R9").Copy wS.Cells(Rows.Count, "A").End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues Application.CutCopyMode = False For i = wS.Cells(Rows.Count, "A").End(xlUp).Row To 2 Step -1 If WorksheetFunction.CountIf(wS.Cells(i, "A").Resize(, 4), "") = 4 Then wS.Cells(i, "A").Resize(, 4).Delete shift:=xlUp '▼ココから追加(H列の数式を入れ直す) lastRow = wS.UsedRange.Rows.Count Range(wS.Cells(2, "H"), wS.Cells(lastRow, "H")).Formula = _ "=IFERROR(IF(MONTH(A2)=MONTH(A3),"""",SUMPRODUCT((MONTH(OFFSET($A$2,0,0,COUNT(A:A)))=MONTH(A2))*OFFSET($E$2,0,0,COUNT(A:A)))),"""")" End If Next i End Sub ※ 安直な方法ですが、 H列の数式をそのまま利用し、エラーの場合は空白にする数式にしています。 こんな感じではどうでしょうか?m(_ _)m

dorasuke
質問者

補足

早速のご指導有難うごさいます。 試した結果を下記の通りにご報告いたします。 元の「請求書1」で記入する行は5ですが目一杯の5行が埋まっているとエラーは出ません。 但し5行より少ない行数でこのエラーが発生します。 入力した5行を除く1~4行でも5行分が反転したところです。 H列の月毎小計 REFはでなくなりました。 H2 =IFERROR(IF(MONTH(A2)=MONTH(A3),"",SUMPRODUCT((MONTH(OFFSET($A$2,0,0,COUNT(A:A)))=MONTH(A2))*OFFSET($E$2,0,0,COUNT(A:A)))),"") 下記の作業列でエラーが出ます。 I2 入金 =IF(AO2="","",IF(COUNTIFS(入金!$I$2:$I$200,AO2)>=1,"入金済",""))   AO2 =IF(A2="","",TEXT(A2,"mm")&B2) 作業列 M2 ID =IF(COUNT($AJ$1:$AJ$201)<ROW($A1),"",INDEX($B$1:$B$189,SMALL($AJ$1:$AJ$201,ROW($A1)))) AJ2 =IF(F2="","",IF(AND(TEXT($A2,"yyyymm")-$K$1*100-K$2=0,COUNTIFS($A$2:$A2,">"&DATE($K$1,K$2,0),$A$2:$A2,"<"&DATE($K$1,K$2+1,1),$B$2:$B2,$B2)=1),ROW(),"")) 作業列 N2 会社名 =IF(M2="","",VLOOKUP(M2,顧客管理,2,FALSE)) & "" O2 件数 =IF(AK2="","",SUMPRODUCT(($B$2:$B$201=$M2)*($AK$2:$AK$201=$K$4)))   AK2 =IF(A2="","",TEXT(YEAR(A2),"0000")&TEXT(MONTH(A2),"00")) 作業列 P2 当月売上 =IF(M2="","",SUMIF($AL:$AL,TEXT($AL$1,"yymm")&$M2,$E:$E))   AL2 =IF(A2="","",TEXT(A2,"yymm")&B2) 作業列

関連するQ&A

  • EXCEL VBA 早く処理をする

    よろしくお願いします 下の構文を標準モジュールに書き込み、callで実行しているのですが 処理に時間がかかります。 処理を早くする方法と構文の簡素化のご教示をお願いします。 Application.ScreenUpdating = False For i = 1 To 12 With Worksheets(i) .Select LastRow = .Range("A150").End(xlUp).Row + 1 .Range("A8:G" & LastRow).Sort Key1:=Range("A8"), order1:=xlAscending .Range("G8:G" & LastRow - 1).Formula = "=G7+E8-F8" LastRow = .Range("A150").End(xlUp).Row + 1 .Range("A" & LastRow).Select Dim EndRow As Long EndRow = .Range("A" & Rows.Count).End(xlUp).Row Cells(Rows.Count, 1).End(xlUp).Offset(1, 3) = .Name & "合計" Cells(Rows.Count, 1).End(xlUp).Offset(1, 4) = Application.WorksheetFunction.Sum(Range("E7:E" & EndRow)) Cells(Rows.Count, 1).End(xlUp).Offset(1, 5) = Application.WorksheetFunction.Sum(Range("F7:F" & EndRow)) Cells(Rows.Count, 1).End(xlUp).Offset(2, 3) = "前月繰越" Cells(Rows.Count, 1).End(xlUp).Offset(2, 4) = .Range("G7") Cells(Rows.Count, 1).End(xlUp).Offset(2, 5) = "" Cells(Rows.Count, 1).End(xlUp).Offset(3, 4) = "" Cells(Rows.Count, 1).End(xlUp).Offset(3, 3) = "次月繰越" Cells(Rows.Count, 1).End(xlUp).Offset(4, 3) = "合計" Cells(Rows.Count, 1).End(xlUp).Offset(3, 5) = Cells(Rows.Count, 1).End(xlUp).Offset(2, 4) + Cells(Rows.Count, 1).End(xlUp).Offset(1, 4) - Cells(Rows.Count, 1).End(xlUp).Offset(1, 5) Cells(Rows.Count, 1).End(xlUp).Offset(4, 4) = Cells(Rows.Count, 1).End(xlUp).Offset(2, 4) + Cells(Rows.Count, 1).End(xlUp).Offset(1, 4) Cells(Rows.Count, 1).End(xlUp).Offset(4, 5) = Cells(Rows.Count, 1).End(xlUp).Offset(3, 5) + Cells(Rows.Count, 1).End(xlUp).Offset(1, 5) Cells(Rows.Count, 1).End(xlUp).Offset(1, 6) = "" Cells(Rows.Count, 1).End(xlUp).Offset(2, 6) = "" Cells(Rows.Count, 1).End(xlUp).Offset(3, 6) = "" Cells(Rows.Count, 1).End(xlUp).Offset(4, 6) = Cells(Rows.Count, 1).End(xlUp).Offset(0, 6) .Range("C7").End(xlDown).Select Selection.Offset(4, 2).Borders(xlEdgeTop).Weight = xlHairline Selection.Offset(4, 2).Borders(xlEdgeBottom).LineStyle = xlDouble Selection.Offset(4, 3).Borders(xlEdgeTop).Weight = xlHairline Selection.Offset(4, 3).Borders(xlEdgeBottom).LineStyle = xlDouble Selection.Offset(4, 4).Borders(xlEdgeTop).Weight = xlHairline Selection.Offset(4, 4).Borders(xlEdgeBottom).LineStyle = xlDouble Selection.Offset(0, 2).Borders(xlEdgeTop).Weight = xlHairline Selection.Offset(0, 2).Borders(xlEdgeBottom).LineStyle = xlContinuous Selection.Offset(0, 2).Borders(xlEdgeBottom).Weight = xlThin Selection.Offset(0, 3).Borders(xlEdgeTop).Weight = xlHairline Selection.Offset(0, 3).Borders(xlEdgeBottom).LineStyle = xlContinuous Selection.Offset(0, 3).Borders(xlEdgeBottom).Weight = xlThin Selection.Offset(0, 4).Borders(xlEdgeTop).Weight = xlHairline Selection.Offset(0, 4).Borders(xlEdgeBottom).LineStyle = xlContinuous Selection.Offset(0, 4).Borders(xlEdgeBottom).Weight = xlThin End With Next i Application.ScreenUpdating = True

  • エクセルで入力シートから別シートに転記・蓄積について

    エクセルVBAで入力シートのA1:D5(5行)の範囲を別シート(DBシート)の転記・蓄積させる方法を教えてください。また、入力データがA1:A5(1行)のときもあれば、A1:D5(5行)の場合ですが・・・ Sub test01() Dim ws1 As Worksheet, ws2 As Worksheet Dim x As Long, y As Long Set ws1 = Sheets("入力") Set ws2 = Sheets("DB") x = ws2.Cells(Rows.Count, "A").End(xlUp).Row + 1 y = ws1.Cells(Rows.Count, "A").End(xlUp).Row ws1.Cells(1, "A").Resize(y, 4).Copy ws2.Cells(x, "A") 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"この処理を簡単な変数の処理で代用できないか ということです。他にも高速化できる方法があれば教えてください。 よろしくお願いします。

  • 列を変更して転記したいのですが。

    すみません、誰か教えていただけませんか。 A列に値が入力がされていて、その値をF列に転記していき 15行までいけば2列横にズレて転記していき更に、15行で 2列横と続けたいのですがうまく出来ません。 下記のように記述してみたのですが、値が置き換わるだけで 転記出来ません。 誰か教えて頂けませんでしょうか。 Sub TEST() Dim i As Long, ii As Long Dim myR As Long myR = Worksheets("sheet1").Cells(Rows.Count, 1).End(xlUp).Row ii = 5 For i = 1 To myR Cells(1, ii).End(xlUp).Offset(0, 1).Value = Cells(i, 1).Value If Cells(1, ii).End(xlUp).Row = 15 Then ii = ii + 2 End If Next i End Sub 宜しくお願いします。

  • エクセルVBAで行のコピー貼り付けについて

    初心者、勉強中でエクセル2007です。 A1行からK40行までの表があります。 これを下にコピーをしながら増やしていってるのですが、マクロでしようと思い下記のとおり 考えました。 selecion.row.Offset(39, -1).Select ここでオブジェクトが必要ですと出ます。 それからその下の?とを色々ぐぐってみますがどうしてもわかりません。 それと2007ですので65536行ではないのですが、MaxRow = Cells(Rows.Count, 1).End(xlUp).Row だと動かないみたいですので下記としています。 よろしくご教授お願いします。 Sub Gcopy() MaxRow = Range("B65536").End(xlUp).Offset(-39, -1).Select データの入ってる最終行を取得 Selecion.row.Offset(39, -1).Select 選択された行から上に39行移動し選択 ?                    下へ39行まで選択   MaxRow = Range("B65536").End(xlUp).Offset(1, -1) 最終行を取得 ActiveSheet.Paste 貼り付け 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"), _ どなたかご教授の方お願い致します。

  • VBA 請求データ一覧からの複数の処理

    先週 kkkkkmさんに質問をさせて頂きまして、 いろいろご指導を頂いたものです。 続編の様な形になってしまいますが、 抽出するデータの環境設定を変更致しました。 ご質問させて頂く内容は前回とほとんど変更がないのですが、 あらためて下記に記載させて頂きます。 <Worksheet1のデータ> J列~AM列までが課税金額 「J,K,L」「M,N,O」・・・「AK,AL,AM」と3列1組(コード・費目・金額) 1組の行もあれば、複数組の行もあり。 AN列~BB列までが非課税金額 課税金額と同じく3列1組 1組の行もあれば、複数組の行もあり。 「BC」=消費税、「BD」=合計金額 ※AN列の前に不規則な空白セルあり   BC列の前に不規則な空白セルあり 文章で上手く説明出来ているか自信がありませんので、 エクスポートした元データ Worksheet1と、 vbaを用いて作成した Worksheet3 をご参考に添付致します。 Worksheet1の2行目がWorksheet3の2行目に対応しています。 3行目、4行目も同様です。 不規則な空白が原因でしょうか・・・。 M列、O列は問題ないのですが、 金額が合わなかったり、N列に金額を引いてこないのです。 実行しているコードは下記になります。 Dim i As Long, j As Long, k As Long Dim Ws1 As Worksheet, Ws2 As Worksheet, Ws3 As Worksheet Dim mTotal(4) As Long Dim LastRow As Long Dim List(4) As Variant Set Ws1 = Sheets("Sheet1") Set Ws2 = Sheets("Sheet2") Set Ws3 = Sheets("請求書ひな形") List(1) = Ws2.Range(Ws2.Cells(1, "A"), Ws2.Cells(Rows.Count, "A").End(xlUp)).Value List(2) = Ws2.Range(Ws2.Cells(1, "B"), Ws2.Cells(Rows.Count, "B").End(xlUp)).Value List(3) = Ws2.Range(Ws2.Cells(1, "C"), Ws2.Cells(Rows.Count, "C").End(xlUp)).Value List(4) = Ws2.Range(Ws2.Cells(1, "D"), Ws2.Cells(Rows.Count, "D").End(xlUp)).Value LastRow = UBound(List(1)) For i = 2 To 4 If LastRow < UBound(List(i)) Then LastRow = UBound(List(i)) End If Next For i = 2 To Ws1.Cells(Rows.Count, "J").End(xlUp).Row mTotal(1) = 0 mTotal(2) = 0 mTotal(3) = 0 mTotal(4) = 0 For j = Columns("J").Column To Columns("BB").Column Step 3 For k = 2 To LastRow If UBound(List(1)) >= k Then If Ws1.Cells(i, j).Value = List(1)(k, 1) Then mTotal(1) = mTotal(1) + Ws1.Cells(i, j).Offset(0, 2).Value Exit For End If End If If UBound(List(2)) >= k Then If Ws1.Cells(i, j).Value = List(2)(k, 1) Then mTotal(2) = mTotal(2) + Ws1.Cells(i, j).Offset(0, 2).Value Exit For End If End If If UBound(List(3)) >= k Then If Ws1.Cells(i, j).Value = List(3)(k, 1) Then mTotal(3) = mTotal(3) + Ws1.Cells(i, j).Offset(0, 2).Value Exit For End If End If If UBound(List(4)) >= k Then If Ws1.Cells(i, j).Value = List(4)(k, 1) Then mTotal(4) = mTotal(4) + Ws1.Cells(i, j).Offset(0, 2).Value Exit For End If End If Next Next Ws3.Cells(i, "J").Value = mTotal(1) Ws3.Cells(i, "K").Value = mTotal(2) Ws3.Cells(i, "L").Value = mTotal(3) Ws3.Cells(i, "N").Value = mTotal(4) Ws3.Cells(i, "M").Value = Ws1.Cells(i, "BC").Value Ws3.Cells(i, "O").Value = Ws1.Cells(i, "BD").Value Next Set Ws1 = Nothing Set Ws2 = Nothing Set Ws3 = Nothing End Sub 本当に何度も申し訳ございません。 お時間がある時に見て頂けると有り難いです。 どうぞ宜しくお願い致します。

  • (再)エクセル データ並び替え

    前回、こちらで質問させて頂いた者です。 http://okwave.jp/qa/q7917475.html 一度は解決したのですが、 エクセルの表を作り変える必要が出てきて、セルの位置などが変わってしまい、 教えていただいたマクロではエラーが出てしまって並び替えができなくなってしまいました。 前回:1行目がタイトル行     データは2行目以降(A・B列は2行ずつ結合) ↓ 変更:4行目がタイトル行     データは5行目以降(A・B・C列は2行ずつ結合)     少し変わっただけなので、このへんかな~と勝手に見当をつけて自分でマクロをいじってみたのですが、検討違いのようでエラーばっかりで直りません(T0T) (マクロはとっても苦手です・・) 下のマクロが、以前の質問で回答してくださった方から教えていただいたマクロなんですが、 ここのどこを変えれば、変更後の表に対応できるようになりますでしょうか? どなたか教えてください~(>_<) ・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・ Sub 並び替え() 'この行から Dim i As Long Application.ScreenUpdating = False 'セルの分割 For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row Step 2 With Cells(i, 1) .UnMerge .Offset(, 1).UnMerge .Offset(1) = Cells(i, 1) .Offset(1, 1) = Cells(i, 2) End With Next i Cells(1, 1).CurrentRegion.Sort key1:=Cells(1, 1), order1:=xlAscending, Header:=xlYes _ , key2:=Cells(1, 2), order2:=xlAscending, Header:=xlYes 'セルの再結合 For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row - 1 Step 2 Application.DisplayAlerts = False With Cells(i, 1) .Resize(2, 1).Merge .Offset(, 1).Resize(2, 1).Merge End With Next i Application.ScreenUpdating = True End Sub 'この行まで ・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・ また、わがままで申し訳ないのですが、グループごとに並び変えるときに、さらに名簿順になるように並び替えられると助かるのですが、何か文を追加することで、そういう並び替えになりますか? もし可能なら、それも教えて頂きたいです。 なにとぞ、よろしくお願いしますm(_ _)m

  • VBAでの処理分岐方法を教えてほしいです

    VBAの分岐処理で悩んでおります。 誰かお助けお願いします。 A列に昇順で番号があります。 1 2 4 4 5 6 9 欠番や重複した数値があります。 やりたいことは欠番箇所に行を挿入し、連番にしたいです。 この例で言うと、3行目に1行を挿入し番号を3と入れる、6行目に2行挿入し7,8と連番にする。 連番になった後に、重複した数値に色を付けます。 以下私が作成したコードです。callで呼び出す予定です。 Sub 欠番判定数式() Dim i As Integer For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row Cells(i, 3) = "=if(iserror(if(A" & i & "-A" & i - 1 & ">1,""○"","" "")),"""",if(A" & i & "-A" & i - 1 & ">1,""○"","" ""))" Next End Sub Sub 行挿入() Dim c As Range, Target As Range For Each c In Range("C2:C" & Cells(Rows.Count, 1).End(xlUp).Row) If c = "○" Then If Target Is Nothing Then ''(1) Set Target = c Else Set Target = Union(Target, c) ''(2) End If End If Next c If Not Target Is Nothing Then Target.Select Selection.EntireRow.Insert , copyorigin:=xlFormatFromLeftOrAbove End Sub Sub 空白連番入力() Dim i As Integer For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row If Cells(i, 1) = "" Then Cells(i, 1) = (Cells(i, 1).Offset(1, 0).Value) - 1 End If Next End Sub Sub 番号重複確認() Dim i As Integer For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row If Application.WorksheetFunction.CountIf(Range("$A$2:$A$" & Cells(Rows.Count, 1).End(xlUp).Row), Range("A" & i)) <> 1 Then Cells(i, 1).Interior.ColorIndex = 3 End If Next End Sub このコードを順に全て実行した時、1回目の処理で3行目と5行目に行挿入、そして番号が3と7と入力され連番に色が設定されます。 再度「欠番判定数式」を行い、次は8行目に行挿入し8と連番を入力させ処理を繰り返しさせたいです。 欠番は例として最高2個にしてますが、これから2個以上の可能性もあります。 一度全処理終了後、再度最初の処理(欠番判定数式)に戻り、欠番がある場合は行挿入させという処理を行わせ、欠番がない場合は次の処理に進めるという分岐方法を教えてほしいです。 よろしくお願いいたします

  • VBAのスピードについてご教示ください

    下記マクロは、シートAに氏名、郵便番号、住所・・・、と横に住所録を整理していて、列11番目に「対象」と入力されている行を順番にコピーして、シート「送付先一覧」に貼り付けるマクロをコピーしてエクセル2010で使用させていただいてるのですが、職場のエクセル2007では極端にスピードが遅くなります。 エクセル2007では、2010のように早くはならないのでしょうか? 2007を使用してるパソコンが、少し古いからでしょうか? 素人でよくわかりません。 遅くなる理由、また早くする方法があればご教示ください。 Sub 対象抽出() Dim i, LastRow As Long LastRow = Cells(Rows.count, 11).End(xlUp).Row For i = 1 To LastRow If Cells(i, 11) = "対象" Then Rows(i).Copy Sheets("送付先一覧").Cells(Rows.count, 1).End(xlUp).Offset(1, 0) End If Next i End Sub

専門家に質問してみよう