Split two rows in a table based on values in two rows in vba, excel

Question

I am new to VBA. How do I split the entire row based on the values in col D and col F? I have around 1,200 rows.

Note: I am looking to Replace the old values in the same sheet.

My Old Sheet looks something like this:

  A              B       C      D           E     F             G       H  
9/9/2015 9:54    500    glass   2           1   590             ABC 123 NULL
6/8/2015 8:55    501    glass   3 to 4      1   400 to 500      XYZ 259 NULL
5/8/2015 8:55    502    glass   1 to 2      1   675 to 750      J8H 1X4 NULL
1/11/2015 9:55   503    glass   Base to 2   1   425 to 575      J1K 2N1 NULL
1/1/2015 8:55    504    glass   3           2   1030 to 1050    H7G 3B5 NULL
16/1/2015 9:55   505    glass   2           2   1600 to 1800    H7W 5E4 NULL

The expected sheet should look like this

  A              B       C      D       E    F       G        H     
9/9/2015 9:54    500    glass   2       1   590     ABC 123 NULL
6/8/2015 8:55    501    glass   3       1   400     XYZ 259 NULL
6/8/2015 8:55    501    glass   4       1   500     XYZ 259 NULL
5/8/2015 8:55    502    glass   1       1   675     ABC 123 NULL
5/8/2015 8:55    502    glass   2       1   750     ABC 123 NULL     
1/11/2015 9:55   503    glass   Base    1   425     ABC 123 NULL
1/11/2015 9:55   503    glass   2       1   575     ABC 123 NULL
1/1/2015  8:55   504    glass   3       2   1040    ABC 123 NULL
16/1/2015 9:55   505    glass   2       2   1700    ABC 123 NULL

Split into two when col. D = range, (row 2 (old sheet))
Split when both D & F are range, (row 3 and 4 (old sheet))
Take Average when only F is range. (row 5 and 6 (old sheet))
Ignore otherwise. (row 1 (old sheet))

EDIT:

This is how i tried coding it:

Sub Split()
    Dim cl As Range, x&, z&, k
    Dim Dic As Object: Set Dic = CreateObject("Scripting.Dictionary")

    With ActiveSheet 'replace `activesheet` by `sheets("specifysheetname")` if required
        x = .Cells(.Rows.Count, "D").End(xlUp).Row: z = 1
        For Each cl In .Range("D1:D" & x)
            If LCase(cl.Value2) Like "*to*" And _
                LCase(cl.Offset(, 1).Value2) Like "*to*" Then
                Dic.Add z, Split(cl.Value2)(0) & ";" & Split(cl.Offset(, 1).Value2)(0): z = z + 1
                Dic.Add z, Split(cl.Value2)(2) & ";" & Split(cl.Offset(, 1).Value2)(2)
            ElseIf Not (LCase(cl.Value2) Like "*to*") And _
                LCase(cl.Offset(, 1).Value2) Like "*to*" Then
                Dic.Add z, cl.Value2 & ";" & Application.Average(Split(cl.Offset(, 1).Value)(0), _
                                                        Split(cl.Offset(, 1).Value)(2))
            Else
                Dic.Add z, cl.Value2 & ";" & cl.Offset(, 1).Value2
            End If
            z = z + 1
        Next cl

        For Each k In Dic
            .Cells(k, "D").Value2 = Split(Dic(k), ";")(0)
            .Cells(k, "F").Value2 = Split(Dic(k), ";")(1)
        Next k
    End With

End Sub

Seems a bit messed up. I am not getting the desired result. I have difficulty copying the other values of the row.

Any Help is much appreciated. Thanks in advance.

Should your references be columns E and G rather than D and F? — nbayly
Also please show what you have done so far, what research you have done, etc. Remember that SO is not a code writing service but rather a forum to get targeted advice on coding errors. — nbayly
Look into using IsNumeric as you loop through your rows. You can check if it is a number or a range and act accordingly. If you get stuck, post your code, and someone will help you fix it. — Tim

Hambone Hambone · Accepted Answer · 2016-11-01T02:21:57

I think the easiest thing to do is to create a brand new sheet, adding rows as necessary.

Something like this should work:

  Dim ws1, ws2 As Worksheet
  Dim row2 As Integer
  Dim rw As Range
  Dim dv, fv As Variant

  Set ws1 = Sheets("Sheet1")
  Set ws2 = Sheets.Add
  row2 = 1

  For Each rw In ws1.Rows
    If rw.Cells(1, 1).Value2 = "" Then
      Exit For
    End If

    dv = Split(rw.Cells(1, 4).Value2, " to ")
    fv = Split(rw.Cells(1, 6).Value2, " to ")

    ws2.Cells(row2, 1).EntireRow.Value = rw.Value

    If UBound(dv) = 0 Then
      If UBound(fv) = 1 Then
        ws2.Cells(row2, 6).Value2 = (Val(fv(0)) + Val(fv(1))) / 2
      End If
    Else
      ws2.Cells(row2, 4).Value2 = dv(0)
      ws2.Cells(row2, 6).Value2 = fv(0)
      row2 = row2 + 1
      ws2.Cells(row2, 1).EntireRow.Value = rw.Value
      ws2.Cells(row2, 4).Value2 = dv(1)
      ws2.Cells(row2, 6).Value2 = fv(UBound(fv))
    End If

    row2 = row2 + 1

  Next rw

Then, at the end, just copy the data from the new sheet to the old and delete the new sheet.

  ws1.Rows("1:" & row2).Value = ws2.Rows("1:" & row2).Value

  Application.DisplayAlerts = False
  ws2.Delete
  Application.DisplayAlerts = True

-- EDIT 11/4/2016 --

In response to your comment, I think this is what you would want to do if you wanted to split column F's values instead of averaging.

I basically hijacked the code I used to split column D.

If UBound(dv) = 0 Then
  If UBound(fv) = 1 Then
    ws2.Cells(row2, 4).Value2 = dv(0)
    ws2.Cells(row2, 6).Value2 = fv(0)
    row2 = row2 + 1
    ws2.Cells(row2, 1).EntireRow.Value = rw.Value
    ws2.Cells(row2, 4).Value2 = dv(0)
    ws2.Cells(row2, 6).Value2 = fv(UBound(fv))
  End If
Else
  ws2.Cells(row2, 4).Value2 = dv(0)
  ws2.Cells(row2, 6).Value2 = fv(0)
  row2 = row2 + 1
  ws2.Cells(row2, 1).EntireRow.Value = rw.Value
  ws2.Cells(row2, 4).Value2 = dv(1)
  ws2.Cells(row2, 6).Value2 = fv(UBound(fv))
End If

Split two rows in a table based on values in two rows in vba, excel

1 Answers