マクロ 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
![その他([技術者向] コンピューター) イメージ](https://gazo.okwave.jp/okwave/images/related_qa/c205_4_thumbnail_img_sm.png)
お礼
アドバイスありがとうございました。 何とか希望通りのコードを組み上げました。