Sub •i”Ô•ÏŠ·() Dim intRow As Integer Dim i As Integer Dim strHin As String Dim strHin2 As String Dim strHin3 As String Dim strHin4 As String Dim intLen As Integer Dim intSu As Integer Dim intSu2 As Integer Dim intBun As Integer Dim strSeib As String Dim N As Integer Dim strTex1 As String, strTex2 As String Sheets("Sheet1").Select intRow = Range("B4").End(xlDown).Row For i = 5 To intRow Range("C" & i).Select If Len(Range("C" & i)) > 6 And Len(Range("C" & i)) < 10 Then N = N + 1 Next For i = 5 To intRow + N Range("C" & i).Select If Mid(Range("C" & i), 3, 1) = "-" And Mid(Range("C" & i), 6, 1) = "." Then intLen = Len(Range("C" & i)) If intLen = 8 Then intBun = 2 strHin = Left(Range("C" & i), 2) strHin2 = Mid(Range("C" & i), 4, 2) strHin3 = Mid(Range("C" & i), 7, 2) strSeib = Range("B" & i) intSu = Range("G" & i) intSu2 = intSu / intBun strTex1 = Range("E" & i) strTex2 = Range("F" & i) Range("D" & i).Value = strHin2 Range("B" & i + 1 & ":G" & i + 1).Select Selection.EntireRow.Insert , CopyOrigin:=xlFormatFromLeftOrAbove Range("B" & i + 1).Value = strSeib Range("C" & i + 1).Value = strHin Range("D" & i + 1).Value = strHin3 Range("E" & i + 1).Value = strTex1 Range("F" & i + 1).Value = strTex2 Range("G" & i + 1).Value = intSu2 Range("C" & i).Value = strHin Range("G" & i).Value = intSu2 Range("C" & i).Select End If End If Next End Sub