Row Duplication With Tricky Variables

Hi there,

Having had some extremely helpful responses on this forum in the recent past, I thought I'd return for some more Excel Macro/VBA help.

I've attached an example spreadsheet with the problem.

1. I work with timetable data sets which are often thousands of rows in length.

2. Each row in the example spreadsheet represents a booking, but the data is often a mixture of bookings in single and multiple locations. Some rows are designated for only one room, while others contain multiple locations in the "Location" column.

3. I've been trying to devise an automated method of turning the data as it is in the "Initial Data" tab to how it looks in the "Desired Outcome" tab.

4. What I need is for a Macro that works through the data, identifying when a booking (i.e. a row ) has multiple locations attributed to it. The macro then needs to copy the entire row, and copy/insert as many rows as are necessary underneath in order to produce one row per location. All of the other data remains the same - it is just the location that needs to be unique in each of the new copied/inserted rows.

5. The main challenge here is that the locations are often separated by various characters, such as "/" and ",", but can also be separated by other characters as well. If there is no way to produce a macro that can identify which, then a solution that can be easily edited to look for specific characters (defined by the user) between locations would be desirable.


6. The data is often thousands of rows in length, so the macro needs to continue working until no more data exists to process.


At its core, this is another (relatively) simple duplication macro, but with some variables (i.e. the number of different locations and the characters separating each location) that make this kind of macro way out of my technical depth. It's all about the "Location" column, with the remaining columns needing simply to be copied identically, with only the Location differing in each resulting duplicated row.

The manual method for this (text to columns with specified character as delimiter, then copying/pasting the required number of rows below the data, then copying the text-to-columns locations and transpose-pasting them down in the location column) takes way, way too long when there are thousands of rows to work with!

I appreciate any advice and input on the matter!

Try this:

It will replace any /, \, or | with a comma (add more delimeters if needed) so that the split function can separate the Locations into an array. Hope it does what you want!

Option Explicit

Public Sub SortData()
  Dim sh1 As Worksheet, sh2 As Worksheet
  Dim r1 As Long, r2 As Long, x As Long, LastRow As Long, LastCol As Long
  Dim Locations As String, Location() As String

  Set sh1 = ThisWorkbook.Worksheets("Initial Data")
  Set sh2 = ThisWorkbook.Worksheets("Desired Outcome")
  
  LastRow = sh1.Cells(Rows.Count, 1).End(xlUp).Row
  LastCol = sh1.Cells(1, Columns.Count).End(xlToLeft).Column
  
  sh2.Cells.Clear
  sh2.Range(sh2.Cells(1, 1), sh2.Cells(1, LastCol)).Value = sh1.Range(sh1.Cells(1, 1), sh1.Cells(1, LastCol)).Value
  sh2.Range(sh2.Cells(1, 1), sh2.Cells(1, LastCol)).Font.Bold = True
  r2 = 2
  
  For r1 = 2 To LastRow Step 1
    Locations = Replace(sh1.Cells(r1, 4).Value, "/", ",")
    Locations = Replace(Locations , "\", ",")
    Locations = Replace(Locations , "|", ",")
    Location = Split(Locations, ",")
    
    sh2.Range(sh2.Cells(r2, 1), sh2.Cells(r2 + UBound(Location), LastCol)).Value = sh1.Range(sh1.Cells(r1, 1), sh1.Cells(r1, LastCol)).Value
    For x = 0 To UBound(Location) Step 1
      sh2.Cells(r2 + x, 4).Value = Trim(Location(x))
    Next
    
    r2 = r2 + UBound(Location) + 2
  Next
End Sub

This is almost perfect! I'm having two small problems with this however:

1. Everything copies as it should in the right order, but the values in the "Binary Weeks" column get butchered, and can't be turned back to their original values, even when formatting as text/number. Is there any way to resolve this? The "Binary Weeks" format in "Initial Data" is essential to the rest of the work I do with the data. It's formatted as "Text" in "Initial Data", but it's "General" in the "Desired OUtcome" sheet after running the Macro. Essentially, I'd like the Binary Weeks number format in "Desired Outcome" to look identical (i.e. 0's and 1's in the correct order) to the format in "Initial Data". As it stands, the Binary Weeks can't be returned to their pre-macro format, even when changing cell format to General/Number etc. This may be my fault for not stressing its importance!

2. If I wanted to run the Macro from my personal workbook as opposed to a module on this specific workbook, would this be too much of an edit?

This is great. Problem 1. Solved!

Will wait to hear back about problem 2. Just realised your location - thank you for taking the time!

I've changed it so that it uses the active sheet, and it overwrites the input with the output. I think this should work in a personal workbook - good luck!

Public Sub SortData()
  Dim sh As Worksheet
  Dim r1 As Long, r2 As Long, x As Long, LastRow As Long, LastCol As Long
  Dim Locations As String, Location() As String

  Set sh = ActiveSheet
  
  LastRow = sh.Cells(Rows.Count, 1).End(xlUp).Row
  LastCol = sh.Cells(1, Columns.Count).End(xlToLeft).Column
  
  r2 = LastRow + 2
  
  For r1 = 2 To LastRow Step 1
    Locations = Replace(sh.Cells(r1, 4).Value, "/", ",")
    Location = Split(Locations, ",")
    
    sh.Range(sh.Cells(r2, 14), sh.Cells(r2 + UBound(Location), 14)).NumberFormat = "@"
    sh.Range(sh.Cells(r2, 1), sh.Cells(r2 + UBound(Location), LastCol)).Value = sh.Range(sh.Cells(r1, 1), sh.Cells(r1, LastCol)).Value
    For x = 0 To UBound(Location) Step 1
      sh.Cells(r2 + x, 4).Value = Trim(Location(x))
    Next
    
    r2 = r2 + UBound(Location) + 2
  Next
  sh.Range(sh.Rows(2), sh.Rows(LastRow + 1)).Delete Shift:=xlUp
End Sub

Again, I can't thank you enough for your help in this matter!

The code works perfectly, and shall save a great deal of time for me.

All the Best

Again, I can't thank you enough for your help in this matter!

The code works perfectly, and shall save a great deal of time for me.

All the Best