Macro to split a cell data into rows and copying other cells as it is in rows

Plz find the attachement in which there are some cell in column D which have data like S22A/S22B/S22C/S22D or BS12/BS17/BS07/BS03 like that to split these in row and also to copy the data of other row & column.

shaan65,

Received your Private Message.


Detach/open workbook SplitDataV2 - shaan65 - EF754025 - SDG13.xls and run macro SplitDataV2.


If your problem is solved, please say so clearly, and mark your thread as Solved: Click the Edit button on your first post in the thread, Click Go Advanced, select [SOLVED] from the Prefix dropdown, then click Save Changes. If more than two days have elapsed, the Edit button will not appear -- ask a moderator to mark it.

shaan65,

You are welcome.

If your problem is solved, please say so clearly, and mark your thread as Solved: Click the Edit button on your first post in the thread, Click Go Advanced, select [SOLVED] from the Prefix dropdown, then click Save Changes. If more than two days have elapsed, the Edit button will not appear -- ask a moderator to mark it.

shaan65,

The following macro will cycle thru all the worksheets in the workbook.


Please TEST this FIRST in a COPY of your workbook (always make a backup copy before trying new code, you never know what you might lose).

Option Explicit
Sub SplitDataV3()
' stanleydgromjr, 11/22/2010, EF754025
Dim c As Range, firstaddress As String, Sp, a As Long
Dim ws As Worksheet
Application.ScreenUpdating = False
For Each ws In ThisWorkbook.Worksheets
  With ws
    With ws.Columns(4)
      firstaddress = ""
      Set c = .Find("*/*", LookIn:=xlValues, LookAt:=xlWhole)
      If Not c Is Nothing Then
        firstaddress = c.Address
        Do
          Sp = Split(c, "/")
          a = UBound(Sp)
          c.Offset(1).Resize(a).EntireRow.Insert
          ws.Range("B" & c.Row & ":L" & c.Row).Copy ws.Range("B" & c.Row + 1 & ":B" & c.Row + a)
          c.Resize(a + 1).Value = Application.Transpose(Sp)
          ws.Range("B" & c.Row & ":B" & c.Row + a).RowHeight = 12.75
          ws.Range("B" & c.Row & ":L" & c.Row + a).Interior.ColorIndex = 6
          Set c = .FindNext(c)
          On Error Resume Next
        Loop While Not c Is Nothing And c.Address <> firstaddress
        On Error GoTo 0
      End If
    End With
  End With
Next ws
Application.ScreenUpdating = True
End Sub

Then run the SplitDataV3 macro.