1: 2: 3: 4: 5: 6: 7: 8: 9: 10: 11: 12: 13: 14: 15: 16: 17: 18: 19:
Sub Reorganizedata() Dim mArray As Variant Dim wArray As Variant Dim mS As Worksheet Dim lRow As Long Set mS = ThisWorkbook.Worksheets("Sheet1") lRow = mS.UsedRange.SpecialCells(xlCellTypeLastCell).Row mArray = mS.Range("A1:C" & lRow) wArray = mS.Range("D1:D" & lRow) For i = 1 To lRow If mArray(i, 3) = "Kindergarten" Then wArray(i, 1) = mArray(i, 1) & "," & mArray(i, 2) & "," & LCase(Left(mArray(i, 2), 1)) & LCase(mArray(i, 1)) & "," & "welcome" & "," & mArray(i, 3) & "," & 1 Else wArray(i, 1) = mArray(i, 1) & "," & mArray(i, 2) & "," & LCase(Left(mArray(i, 2), 1)) & LCase(mArray(i, 1)) & "," & "welcome" & "," & mArray(i, 3) & "," & mArray(i, 3) + 1 End If Next i mS.Range("A1:C" & lRow).ClearContents mS.Range("A1:A" & lRow) = wArray End Sub