• Ask a Question
150
Insert Image Size must be less than < 5MB.
    Ask a Question
    Cancel
    150
    More answer You can create 5 answer(s).
      Ask a Poll
      Cancel
      Top Contributor

      Creating Multiple rows

      I would like to create multiple cells from a given data, the code should be able to read the data from a defined cell and split into multiple rows provided certain creteria is met. For instance if the workday is split between two states I would like it to show the name of each of these two states in two rows.

      In this instance the client has stayed in two states as he was traveling, I would like to split this into two entries using VB. It should scan the range, identify such instances and create a separate table with multiple values.

      Creating Multiple rows

      Asked by pranab79in on August 30, 2017 in VBA.
      10 Answers
      Expert

      Hello

      Can you attach sample of your workbook with some of the expected output?

      Answered by YasserKhalil on August 30, 2017..
      • Hi Yasser,

        I am unable to attach the excel, however have attached the screen shot from the same.

        RE: Creating Multiple rowsInput Screen

        RE: Creating Multiple rowsOutput

         

         

         

        on August 31, 2017.
      • Hi Please let me know if you need more information on this.

        on September 4, 2017.
      • Thanks for sharing sample input & output screen shots.

        on September 6, 2017.
      Cancel
      Add comment
      Expert

      HI Pranab,

      Here is the VBA macro for your requirement. I have written comments for each statement for your understand.  You can modify Input sheet name according to you.

      Sub MoveData_To_Multiple_Rows()
      'Variable declaration
      Dim iCntr As Integer, lstRow As Integer
      'Change below Input sheet name
      With Sheets("Sheet2")
      'Find last row
      lstRow = .Cells(.Rows.Count, "A").End(xlUp).Row
      'Loop through all rows
      For iCntr = lstRow To 2 Step -1
      'Check if data is available or not in Column 'F'
      If .Range("F" & iCntr) <> "" Then
      'Add new row
      .Rows(iCntr + 1).Insert Shift:=xlDown
      'Copy Date & Day
      .Range("A" & iCntr & ":" & "B" & iCntr).Copy Destination:=.Range("A" & iCntr + 1)
      'Copy Country & State
      .Range("F" & iCntr & ":" & "G" & iCntr).Copy Destination:=.Range("C" & iCntr + 1)
      'Update Activity as Workday
      .Range("E" & iCntr + 1) = "Work Day"
      'Split Count
      .Range("J" & iCntr & ":" & "J" & iCntr + 1) = 0.5
      'Delete data
      .Range("F" & iCntr & ":" & "I" & iCntr) = ""
      End If
      Next
      End With
      End Sub
      

      Hope it help you. Please do let me know, If you need any further modifications.

      Regards!

      Answered by Valli on September 6, 2017..
      Top Contributor

      Valli sir-when I run this macro nothing seems to be happening, am I missing something. I would want the macro to search for rows with Workday and wherever there are multiple states, copy them in separate rows either on Sheet 1 or Sheet 2 as separate entries.

      Answered by pranab79in on September 6, 2017..
      Expert

      It will be better to upload sample of your workbook with dummy data .. if there is sensitive data

      Answered by YasserKhalil on September 6, 2017..
      Top Contributor

      Unable to attach the excel sheet, do I need to subscribe to something before I do it? I don’t mind doing that as well. Please let me know

      Answered by pranab79in on September 7, 2017..
      Expert

      You can upload your file to any of file host uploading .. Try this site

      https://wetransfer.com

      Upload the file then copy the link and post it here

      Answered by YasserKhalil on September 7, 2017..
      Top Contributor

      Hi Yaseer here is the link https://we.tl/8R9kqh99SX

      Answered by pranab79in on September 7, 2017..
      Expert

      Hello Try this code

      Sub Test()
      Dim a As Variant
      Dim b As Variant
      Dim i As Long
      Dim j As Long
      Dim k As Long
      With Sheets("Sheet1")
      a = .Range("B3:M" & .Cells(Rows.Count, 2).End(xlUp).Row).Value
      End With
      ReDim b(1 To UBound(a, 1) * 2, 1 To 9)
      For i = LBound(a, 1) To UBound(a, 1)
      k = k + 1
      For j = 1 To 8
      b(k, j) = a(i, j)
      Next j
      If a(i, 9) = "" Then b(k, 9) = 1 Else b(k, 9) = 0.5
      If b(k, 8) = "Non-Workday" Then b(k, 9) = 0
      If a(i, 9) <> "" Then
      k = k + 1
      For j = 1 To 3
      b(k, j) = a(i, j)
      Next j
      b(k, 4) = Trim(Split(a(i, 11), " ")(0))
      b(k, 5) = a(i, 5)
      b(k, 6) = a(i, 9)
      b(k, 7) = a(i, 10)
      b(k, 8) = a(i, 8)
      If b(k, 8) = "Non-Workday" Then
      b(k, 9) = 0
      Else
      b(k, 9) = 0.5
      End If
      End If
      Next i
      With Sheets("Sheet2")
      .Cells.Clear
      .Range("A1").Resize(, 9).Value = Array("Assignee ID", "Assignee Name", "Engagement", "Date", "Day", "Location Country", "Location State/Province", "Activity", "Count")
      .Range("A2").Resize(k, UBound(b, 2)).Value = b
      .Columns(4).NumberFormat = "[$-en-US]d-mmm-yyyy;@"
      .Columns.AutoFit
      End With
      End Sub
      

       

      Answered by YasserKhalil on September 7, 2017..
      Top Contributor

      You are awesome, it works perfectly. Only issue is that the Date format in the Output Sheet is coming in as “Custom” instead of “Date” because of which this needs to be modified manually.

      Answered by pranab79in on September 7, 2017..
      Expert

      You’re welcome..

      You can delete this line

      .Columns(4).NumberFormat = "[$-en-US]d-mmm-yyyy;@"
      

      Then format it as you wish

      or replace the previous line with the proper format

      Answered by YasserKhalil on September 7, 2017..