マクロ 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
お礼
色々と申し訳ありません。 書いたコードの転記間違っていました nag0720様の書いていただいたコードで動きました お手数かけました ありがとうございます。
補足
nag0720様 返答遅れてしまって申し訳ありません。 存在してるシートだけに処理をするという構築が参考になります。 返答頂いてコードを組み込んでみましたが 申し訳ありません。 上手く動かないのです・・・・ 11月の土祝日を除いた状態でシートは存在して全シートに確認するようにしているのですが コードの記述の仕方が変なのでしょうか？ もしよろしければ 確認して頂いてもよろしいでしょうか？ 以下コードになります Sub 転記() Dim w0 As Worksheet, w1 As Worksheet Dim h As Range, Target As Range Dim j As Long For j = 1 To 28 Set w0 = Workbooks("大元データ.xls").Worksheets(1) On Error Resume Next Set w1 = Workbooks("日付管理簿.xls").Worksheets("11月" & j & "日") If Err.Number = 0 Then End If Next For Each h In w0.Range("G7:G" & w0.Range("G65536").End(xlUp).Row) Set Target = w1.Cells.Find(what:=h.Value, LookIn:=xlValues, lookat:=xlWhole) If Not Target Is Nothing Then Select Case h.Offset(0, 1).Value Case "確認" Target.Offset(0, 6) = h.Offset(0, 1).Value Case Else End Select End If Next End Sub 11月1日と11月5日に確認するデータを記述してテストしてみましたが 転記されていない模様です。 お忙しい中申し訳ありません。 確認して頂いてもよろしいでしょうか？