ボタンを押すと、シート１に入力された科目と時限（①～⑤）をシート２に日付と時限を自動で入れたいです。 コードを作ったところ、科目と時限をメッセージで表示させるところまではできましたが、それをIDと科目で突合し、シート２に日付、時限を入れるところでつまずいています。不格好なコードも修正していただけると助かります。セル内の文字の最後に不要な改行を削除するコードを入れたりしています。セル内には改行で科目を分けています。時限は①～⑤を使います。続けて授業する場合には①②や①②③というケースもあります。日付は4月1日から6月30日まで入力されています。ご教示よろしくお願いします。画像が小さく表示されたらすいません。見やすい画像のアップロード方法も教えていただると助かります。 Sub ボタン1_Click() Dim x As Long Dim y As Long Dim i As Long Dim j As Long Dim frow As Long Dim table Dim a As String Dim kamoku As String Dim jigen As String Const kjigen As String = "①②③④⑤" frow = Sheet1.Cells(Rows.Count, 3).End(xlUp).Row With Sheet1 table = .Range(.Cells(12, 7), .Cells(frow, "CS")) End With For y = 1 To UBound(table) For x = 1 To Cells(3, Columns.Count).End(xlToLeft).Column - 6 'セルの最後に改行があれば削除 If table(y, x) <> "" Then a = table(y, x) Do While Right(a, 1) = vbLf '最後の1文字を削除 a = Left(a, Len(a) - 1) Loop '改行が入っているかで分割する If InStr(a, vbLf) <> 0 Then value = Split(a, vbLf) '配列 If UBound(value) >= 1 Then For i = LBound(value) To UBound(value) For j = 1 To Len(value(i)) C = Mid(value(i), j, 1) If InStr(1, kjigen, C) > 0 Then jigen = jigen & C End If Next j kamoku = Replace(value(i), jigen, "") MsgBox kamoku & "" & jigen jigen = "" kamoku = "" Next i End If Else 'セルに改行がなかった場合 value = a hiduke = Cells(3, x + 6).value For k = 1 To Len(value) d = Mid(value, k, 1) If InStr(1, kjigen, d) > 0 Then jigen = jigen & d End If Next k kamoku = Replace(value, jigen, "") MsgBox kamoku & "" & jigen kamoku = "" jigen = "" value = "" a = "" d = "" k = "" End If End If Next x Next y End Sub