• ベストアンサー
※ ChatGPTを利用し、要約された質問です(原文:マクロの関係で困ってしまいました。印刷できません)

Excelマクロを使って行の入れ替えをする方法

このQ&Aのポイント
  • Excelのマクロを使用して行の入れ替えを行う方法について質問があります。マクロを組んだのですが、改ページ位置を移動できないというエラーが出ており、解決方法を知りたいです。
  • また、間違った入力をした場合に、一度もとに戻すことはできるのでしょうか?お知恵をお借りしたいです。

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

  • ベストアンサー
回答No.3

こんばんは。 こちらで試してみました。はっきり断言できませんが、こちらの想像では、改ページは、どうやら手動改ページのようですね。不具合そのものは見つかりませんが、マクロを組んでみました。全体のお話の様子では、どうやら、改ページプレビューの状態で処理しているような気がします。本来は、一旦、改ページプレビューをやめて、ノーマルモードにして、同じ反応が出るのか疑問が残るところです。 また、リクエストに従って、2行10列に変えてみました。 ただし、文字データに限ります。数式は、文字データに変換されてしまいますし、書式情報は、元のままです。今回は、ひどく不格好なコードですが、試してみてください。 '// Sub ExchangeData()  Dim i As Variant, k As Variant  Dim j As Variant, m As Variant  Dim x As Range  Dim y As Range  Dim a As Variant  Dim b As Variant  Dim tmp As Variant  Dim tmpAr As Variant  Dim Rng As Range  Set Rng = Range("A1:A250") '検索範囲、ここは1列に限る  i = Application.InputBox("入れ替え元の番号入力", "Source", , , , , , 1)  If i = False And VarType(i) = vbBoolean Then Exit Sub    j = Application.InputBox("入れ替え先の番号入力", "Destine", , , , , , 1)  If j = False And VarType(j) = vbBoolean Then Exit Sub    tmp = Application.Match(i, Rng, False)  If IsError(tmp) Then    MsgBox i & "が見つかりません。", vbCritical: Exit Sub   Else    k = Rng.Cells(tmp).Row 'i の行   End If   Set x = Cells(k, 1).Resize(2, 10) '2行10列     tmp = Application.Match(j, Rng, False)   If IsError(tmp) Then    MsgBox j & "が見つかりません。", vbCritical: Exit Sub   Else    m = Rng.Cells(tmp).Row 'jの行   End If   Set y = Cells(m, 1).Resize(2, 10) '2行10列    a = x.Value '配列代入  b = y.Value    tmpAr = b  y.Resize(2, 10).Value = a  x.Resize(2, 10).Value = tmpAr    Set x = Nothing: Set y = Nothing End Sub

ihuyi
質問者

お礼

みなさんの協力でできました。ノーマルにしてやったら消えました。

全文を見る
すると、全ての回答が全文表示されます。

その他の回答 (2)

回答No.2

こんにちは。 http://detail.chiebukuro.yahoo.co.jp/qa/question_detail/q1335403623 「コントロールパネルからプリンタの設定を変更後、再度デフォルトに変更し直す。」 ここで書かれているように、プリンタードライバーの影響もあるのかもしれません。 >これでやったら80行ぐらいから、この表示が出て、解決できません。どなたか、解決して頂けませんか。 これは、本来、プリンター側から出される物理的限界値の信号が影響しているようです。 ----- >普通に手動で40行ずつ1ページの7ページにできました。できたので、マクロが関係しているのかなと疑った訳です。 再度、確認したいのは、「改ページ」の中の「手動改ページ」を入れているかどうかということです。40行は、どのように設定したのですか?「改ページ」を自分で入れたのか、それとも、上下のマージンで設定されたものか、ということです。 >マクロを掛けるとそれに、80行以降は1行毎にブルーの実線でなく、点線の線になっています。データーの最終行までです。 この辺りの話もよく分かっていないのですが、「改ページプレビュー」でみていただいて、その辺りが、どうなっているのか知りたいのです。 もちろん、こちらでマクロで事前にどうなっているか調べたりすることは可能ですが、直接の問題ではないことで、マクロの手数が多くなるのは、できる限り避けたいと思っているのです。 この話は、分かっていただけますでしょうか?

全文を見る
すると、全ての回答が全文表示されます。
回答No.1

こんばんは。 #8536710 と#8531046を合わせて読みました。 まだ、はっきりしたことが言えませんが、確認ですが、A4サイズからA3に変更っていう所がよく分かりません。プリンター自体にA3は印刷できるわけですよね。言い換えると、プリンタードライバーというのは、その印刷性能の範囲しかありません。その点は大丈夫ですね?最初から、A3で作ったほうがトラブルは少ないような気がします。 次に、「改ページ位置を移動できません」と書かれていますが、その改ページの種類が分からないのです。それは、マクロを掛ける前からのものでしょうか?その改ページは、自動改ページでしょうか、それとも、手動のもの(=ユーザーがいれた改ページ)なのでしょうか? また、データは、オブジェクト単位で入れ替えているようですが、元のデータは、オブジェクト単位で入れ替えしなくてはならないものなのでしょうか?数式や文字などだけでもよいのでしょうか? ふつうは、一旦、改ページを一旦取り去ってから、マクロ処理して、再び、改ページを入れれば、解決するはずです。マクロ自体については、ここの回答のメンバーが書いたものでしょうし、それ自体には、当面の問題は感じません。

ihuyi
質問者

補足

質問の回答  自宅のものと会社のものとで、A4とA3が使えない状況の違いがあります。データーの修正を自宅でして(A4は自宅)A3を会社でためしても現象は変わらずでした。A3で編集し直しましたが変わらずでした。 質問の回答   マクロをかける前はなかったと思います。その後で別sheetにマクロを削除してコピー貼り付けてしたらこの現象は起こらないのです。普通に手動で40行ずつ1ページの7ページにできました。できたので、マクロが関係しているのかなと疑った訳です。また、マクロを掛けるとそれに、80行以降は1行毎にブルーの実線でなく、点線の線になっています。データーの最終行までです。 質問の回答   これは、私はよくわからないのですが、要するに行が入れ替わるのだと思います。また、数式や文字が入れ替わるのでも構いません。入れ替わればよいのです。 質問の回答   前述の通りですが、やってみましたが、結果は同じ現象なので困ってしまったのです。但し、書類作成にはこれで応じられたのでよいのですが、原因を探りたいことと、今後このようなことしがおきたらどのように対処したらと思いまして、質問させて貰いました。 質問の回答のまとめ  初心者で理解できていない単語もあったりで、正確でない回答もあると思います申し訳ありません。不勉強ですみません、但し、マクロが影響しているのではないのでしようね。ご協力ありがとうございます。

全文を見る
すると、全ての回答が全文表示されます。

関連するQ&A

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

    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列からデータを持ってきてプルダウンで表示させたいのですがユーザーフォームでオブジェクトを組まないで表示させる方法を教えてください

  • エクセルのVBAで悩んでいます。

    いつもありがとうございます。 エクセルのVBAで悩んでいます。 セルの範囲指定をVBAで行いたいのです。 ただし、引数に数値変数を使用する為、Cellsプロパティを使います。 すると、離れている範囲の範囲指定が出来ないのです。 例えば、Rangeプロパティだと、 Range("A5:E5,A9:E32").Select こうなるところを、 A9:E32 を変数に置き換えたくて、 Range("A5:E5", Cells(g, 1), Cells(h, 5)).Select と、するとエラーが出ます。 VBAの前文は次の通りです。 Private Sub CommandButton1_Click() a = Me.TextBox1.Value b = Me.TextBox2.Value Set c = Range("a:a").Find(what:=a, LookIn:=xlValues, lookat:=xlWhole) Set d = Range("a:a").Find(what:=b, LookIn:=xlValues, lookat:=xlWhole) 'MsgBox c + d e = c.Address 'MsgBox e f = d.Address 'MsgBox f g = Range(e).Row MsgBox g h = Range(f).Row MsgBox h Range(Cells(g, 1), Cells(h, 5)).Select 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で列を探して最終行までハイパーリンクを付けた

    A列に URL http://oshiete.goo.ne.jp/ http://oshiete.goo.ne.jp/ http://oshiete.goo.ne.jp/ http://oshiete.goo.ne.jp/ http://oshiete.goo.ne.jp/ http://oshiete.goo.ne.jp/ http://oshiete.goo.ne.jp/ http://oshiete.goo.ne.jp/ http://oshiete.goo.ne.jp/ が入ってる場合は、 Sub Sample1() Dim R As Range For Each R In Range("a2:a" & Cells(Rows.Count, "a").End(xlUp).Row) ActiveSheet.Hyperlinks.Add Anchor:=R, Address:=R.Value Next End Sub でハイパーリンクを付けられますが、 URL列がA列じゃない場合の応用の聞かせ方がわかりません。 場合によっては、画像のようにB列であったりC列であったりします。 なので Dim C As Long C = Cells.Find(What:="URL", LookAt:=xlWhole).Column で列番号を取得して、ループさせようと思ったのですが、 For Each R In Range("a2:a" & Cells(Rows.Count, "a").End(xlUp).Row) の部分でどうすればいいのかわかりません。 range表記ではなくcells表記にすればいいような気がしますがどうやって改造すればいいでしょうか? あと、この場合はForEachではなくDoloopやForNextを使った方が良いのでしょうか?

  • EXCELマクロのこの記述の意味を教えてください。

    こんにちは。 以前、教えてもらったマクロですが もう少し深く勉強したいので、記述の 意味(翻訳?)を教えてください。 Sub Test5() Dim FR1 As Range, FR2 As Range With ActiveSheet Set FR1 = .Cells.Find( _ "*", , xlValues, xlWhole, xlByRows, xlPrevious) Set FR2 = .Cells.Find( _ "*", , xlValues, xlWhole, xlByColumns, xlPrevious) End With Range("A1", Cells(FR1.Row, FR2.Column)).Select Set FR1 = Nothing: Set FR2 = Nothing End Sub また、この範囲をA列だけを見る場合、つまりA列の最終行を範囲とする場合は、どう記述すればよいのでしょうか? ぜひ、教えてください。

  • EXCEL マクロの指定の仕方

    マクロで線の色を指定したいのですが、上手くいかず困っています .ForeColor.RGB = Worksheets("sheet1").Range("F2").Interior.ColorIndex 赤色を指定したいのですがBにどういうコードを入れれば良いですか? FはVlookupで列Bより色を指定するようにしています。 マクロは始めたばかりで良く分からないので、他に必要な情報もわかりません 必要な情報なども併せて教えてください。 よろしくお願いします。 Dim rngStart As Range Dim rngEnd As Range Dim BX As Single, BY As Single, EX As Single, EY As Single Set rngStart = Worksheets("sheet2").Cells.Find(What:=Worksheets("sheet1").Range("D2"), LookIn:=xlValues, LookAt:=xlWhole) Set rngEnd = Worksheets("sheet2").Cells.Find(What:=Worksheets("sheet1").Range("E2"), LookIn:=xlValues, LookAt:=xlWhole) BX = rngStart.Left BY = rngStart.Top EX = rngEnd.Left + rngEnd.Width EY = rngEnd.Top With Worksheets("sheet2").Shapes.AddLine(BX, BY + 10, EX, EY + 10).line .ForeColor.RGB = Worksheets("sheet1").Range("F2").Interior.ColorIndex .Weight = 3 .EndArrowheadStyle = msoArrowheadTriangle End With

  • 【至急助けて下さい!!】VBAでのIF関数挿入

    VBA初心者です。上級者の方助けてください。 VBAで入力セルを消去後、IF関数をN列に挿入したいです。 挿入したいIF関数のところが解決できればあとの記述はなんとかなります。 ■挿入したいIF関数 =IF(M4=$Y$5,$Z$9,IF(M4=$Y$6,$Z$9,IF(M4=$Y$7,$Z$9,IF(M4=$Y$8,$Z$6,IF(M4=$Y$9,$Z$10,IF(M4=$Y$10,$Z$9,IF(M4=$Y$14,$Z$7,IF(M4=$Y$15,$Z$8,"")))))))) 他関数は下記構文でうまくいくのですが、 IF関数はどのように記述したらよろしいでしょうか。 ■他 ws.Cells(i, jig_col).Value = "=VLOOKUP(F" & i & ",Sheet1!$A$2:$C$358,2,0)" ■現在の記述 Dim ws As Worksheet Dim endrow As Long Dim endcol As Long Dim you_col As Integer Dim gak_col As Integer Dim jig_col As Integer Dim bc_col As Integer Dim chg_col As Integer Dim i As Long '確認メッセージを表示し、「NO」の場合は処理を行わない If MsgBox("入力されている内容をクリアします。よろしいですか?", vbYesNo) = vbNo Then Exit Sub End If '画面の更新を行わない Application.ScreenUpdating = False Set ws = ThisWorkbook.Sheets("シンフォームイレギュラー運用状況") '呼び出し元シートの最終行、最終列を取得する endrow = ws.Cells(ws.Rows.Count, 6).End(xlUp).Row endcol = ws.Cells.Find(What:="変更フラグ", LookIn:=xlValues, LookAt:=xlWhole).Column - 2 If endrow < 4 Then Exit Sub ws.Range(ws.Cells(4, 1), ws.Cells(endrow, endcol)).ClearContents you_col = ws.Cells.Find(What:="曜日", LookIn:=xlValues, LookAt:=xlWhole).Column gak_col = ws.Cells.Find(What:="学年", LookIn:=xlValues, LookAt:=xlWhole).Column jig_col = ws.Cells.Find(What:="事業所", LookIn:=xlValues, LookAt:=xlWhole).Column 'bc_col = endcol - 1 'chg_col = endcol For i = 4 To endrow ws.Cells(i, you_col).Value = "=B" & i ws.Cells(i, gak_col).Value = "=VLOOKUP(F" & i & ",Sheet1!$A$2:$C$358,3,0)" ws.Cells(i, jig_col).Value = "=VLOOKUP(F" & i & ",Sheet1!$A$2:$C$358,2,0)" 'ws.Cells(i, bc_col).Value = "=IFERROR(MID(H" & i & ",LEN(H" & i & ")-1,1), "")" 'ws.Cells(i, chg_col).Value = 0 ws.Range("W" & i).Value = 0 Next '画面の更新を行う Application.ScreenUpdating = True End Sub

  • ExcelのVBA ListBox.RowSourceの範囲について教えてください。

    下記のように範囲を変数で検索指定したいのですが、うまくいきません。VBAは初心者です。誰か助けて。 内容は・・・五十音順にあるリストを作り、ウ音のみをListBoxに表示したいのですが。 Private Sub ToggleButton3_Click() Dim A As Range Dim BBB As String Dim C As Range Dim DDD As String Set A = Cells.Find(what:="ウ", lookat:=xlWhole) BBB = Cells(A.row, A.Column + 1).Address Set C = Cells.Find(what:="エ", lookat:=xlWhole) DDD = Cells(C.row - 1, C.Column + 1).Address ListBox商品名.RowSource = "BBB:DDD" End Sub PS 違う方法でもいいのでどなたか教えてください。

  • VBA マクロ シート 転記

    はじめまして。VBA初心者です。今シート1のA列1行目セルにA社、A列2行目にB社、A列3行目にC社と・・ざっと1000行程あり、それぞれB列には値があります。この値をシート2のB列に転記したいと思っています。ただ、毎月シートを追加していきますので、左隣のシートから転記しなければなりません。シート2の項目は同じA列とB列で構成されています。A列の値が多少前後するので、FINDを使って以下のようなプログラムを作りました。ただ、左隣のシートから転記とう内容をどうやって追加したら良いのかがわかりません。Previous をどこかに使えばできるのかなとも思うのですが、その方法がわかりません。 Sub 転記() Dim ws As Worksheet, ws1 As Worksheet, r As Range, r1 As Range Dim LastRow As Long, i As Long, er As Long, wkey As String Set ws = Worksheets("Sheet1") Set ws1 = Worksheets("Sheet2") LastRow = ws.Range("A1").End(xlDown).Row er = ws1.Range("A1").End(xlDown).Row Set r = ws.Range("A1:A" & LastRow) For i = 1 To er wkey = ws1.Range("A" & i) Set r1 = r.Find(What:=wkey, LookIn:=xlValues, LookAt:=xlWhole) If Not r1 Is Nothing Then ws1.Range("B" & i) = r1.Offset(, 1) End If Next Set r1 = Nothing Set r = Nothing Set ws = Nothing Set ws1 = Nothing End Sub どなたか詳しいお方いらっしゃいましたら、初心者の私に教えて頂けませんでしょうか?宜しくお願いします。

  • マクロ for~next うまくいかない

    シート内の値を並び替えて、別シートに貼り付けるコード作成中。 ①偶数行の値を奇数行の特定の列に貼り付け、元の値は消す ②(2)と書かれたセルがある場合、その行をコピーして同一行に挿入し、(2)の値は消す この2つが機能しません。 ほか部分は動きます。 これが機能しない原因、分かるでしょうか。 以下、コード Private Sub CommandButton6_Click() Dim i As Long For i = 1 To 9 If Me.Controls("TextBox" & CStr(i)).Value = "" Then 'ユーザーフォーム内のテキスト1~9で空欄があると以下の操作 MsgBox Me.Controls("Label" & CStr(i)).Caption & " が未記入です" '空欄があると、ラベル名+が未記入ですのメッセージ後、処理終了 Exit Sub End If Next Dim Convert_book As String, GC_book As String, GC_address As String Convert_book = TextBox8.Value '変換シートのブック名を取得 GC_book = TextBox7.Value 'ブックAの名前を取得 GC_address = TextBox6.Value 'ブックAの保存先を取得 With Workbooks(GC_book).Worksheets(ws_name) 'ブックAシート1をWithとする。   .Range("A1:CZ200").UnMerge 'ブックAシート1の結合を解く '部品番号と客先コードをコピー .Range(Cells(Range(Parts_no).Row, Range(Parts_no).Column), _ Cells(Range(Parts_no).Row + 1, Range(Parts_no).Column)).Copy '変換シートに貼付けWorkbooks(Convert_book).Worksheets(1).Range("G4").PasteSpecial Paste:=xlPasteValues '管理№をコピー、変換シートに貼付け .Range(Control_no).Copy Workbooks(Convert_book).Worksheets(1).Range("AJ2").PasteSpecial Paste:=xlPasteValues Dim r As Long, r1 As Long, c As Long, c1 As Long, c2 As Long, c3 As Long '管理№の行と列を取得 r = .Range(Control_no).Row c = .Range(Control_no).Column '材料関連の情報のコピーと貼付け .Range(.Cells(r + 2, c - 4), .Cells(r + 3, Last_column - 1)).Copy Workbooks(Convert_book).Worksheets(1).Range("AF4").PasteSpecial Paste:=xlPasteValues '変数に、加工工程№の行と列を入れる。変更年月日の行、測定具の列、管理№の列も入れる。 r = .Range(Process_no).Row '可変 r1 = .Range(Rev_no).Row '可変 c = .Range(Process_no).Column '32または33列目 c1 = .Range(Tool_name).Column '27または28列目 c2 = Last_column '44または43列目 c3 = .Range(Control_no).Column '通常1列目 .Range(Cells(r, c2), Cells(r1 - 2, c2)).Clear '最終列をすべてクリア Dim k As Long, j As Long k = 1 '最終列に1、2、1、……繰返し数を入れる For i = r To r1 - 2 If k = 1 Then .Cells(i, c2).Value = 1 k = k + 1 Else .Cells(i, c2).Value = 2 k = k - 1 End If Next Dim i1 As Long, k1 As Long, j1 As Long k1 = 1 '管理値の欄で偶数列の値を奇数列に移す For i1 = r To r1 - 2 If .Cells(i1, c2).Value = 2 Then For j1 = c3 + 18 To c1 - 1 If .Cells(i1, j1).Value <> "" Then .Cells(i1 - 1, c3 + 25) = .Cells(i1, j1).Value .Cells(i1, j1).Value = "" End If Next j1 End If Next i1 Dim i2 As Long, k2 As Long, j2 As Long k2 = 1 '"(2)"と書いてある行を2行に増やして、"(2)"を消す For i2 = r To r1 - 2 If .Cells(i2, c2).Value = 1 Then For j2 = c3 + 18 To c1 - 1 If .Cells(i2, j2).Value Like "*(2)*" Then .Cells(i2, j2).Formula = Replace(Cells(i2, j2).Formula, "(2)", "") .Range(Cells(i2, 1), Cells(i2, c2)).Copy .Range(Cells(i2, 1), Cells(i2, c2)).Insert xlShiftToRight End If Next j2 End If Next i2 '最終列の番号順に並べる .Range(Cells(r, 1), Cells(r1 - 2, c2)).Sort _ key1:=Cells(r, c2), order1:=xlAscending End With ~~(この間はまだ未作成)~~ Application.DisplayAlerts = False Workbooks(GC_book).Close SaveChanges:=False Application.DisplayAlerts = True End Sub

専門家に質問してみよう