Split a year range into one row per year

[rameez788]

Hi all,
I am new on this forum. I have attached sample data, i need someone to help me convert the left side to how the data looks on the right.

Please let me know if you require any additional information.

Thanks,
RJ

 

[DanteAmor]

I think you could raplace this whole section of code

Hi Peter, thanks for the proposal, I will consider it.

 

[DanteAmor]

I would say smallest year can be 1970. and biggest one is 2020.

From 70 to 2020 is 50 years, I considered a range of 80 years, try the code from post #9

 

[rameez788]

there is another error now please see the screen shots attached

 

[DanteAmor]

Besides having this 2002-2006, could it be that you have letters or some other character?

Move the mouse pointer to the letter i of a (i, 3) and check the number that it shows you there.

Then go to sheet1 and check what data you have in that row, check that you have numbers. If you have letters, try to erase those data or characters.

 

[DanteAmor]

Try this update.
You could try a sample like the one you gave me. With 500 records.

Sub split_year()
  Dim a As Variant, b As Variant
  Dim i As Long, j As Long, k As Long, lr As Long
  Dim nMin As Double, nMax As Double, ini As Long, fin As Long
  Dim sh1 As Worksheet, sh2 As Worksheet
  
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  
  Set sh1 = Sheets("Tab1")
  sh1.Copy after:=Sheets(Sheets.Count)
  Set sh2 = ActiveSheet

  lr = sh2.Range("A:D").Find("*", , xlValues, xlPart, xlByRows, xlPrevious).Row

  With sh2.Range("C3:C" & lr).SpecialCells(xlCellTypeBlanks)
    .Formula = "=IF($B" & .Cells(1).Row & "="""",C" & .Cells(1).Row - 1 & ","""")"
    sh2.Range("C3:C" & lr).Copy
    sh2.Range("C3").PasteSpecial xlPasteValues
  End With
  
  With sh2.Range("B3:B" & lr).SpecialCells(xlCellTypeBlanks)
    .Formula = "=IF($A" & .Cells(1).Row & "="""",B" & .Cells(1).Row - 1 & ","""")"
    sh2.Range("B3:B" & lr).Copy
    sh2.Range("B3").PasteSpecial xlPasteValues
  End With

  With sh2.Range("A3:A" & lr).SpecialCells(xlCellTypeBlanks)
    .Formula = "=A" & .Cells(1).Row - 1
    sh2.Range("A3:A" & lr).Copy
    sh2.Range("A3").PasteSpecial xlPasteValues
  End With
  
  Application.CutCopyMode = False
  a = sh2.Range("A3", Range("F" & lr)).Value2
  ReDim b(1 To UBound(a, 1) * 80, 1 To 4)
  
  For i = 1 To UBound(a, 1)
    If a(i, 3) <> "" Then
      If InStr(a(i, 3), "-") Then
        ini = Val(Split(a(i, 3), "-")(0))
        fin = Val(Split(a(i, 3), "-")(1))
      Else
        If IsNumeric(a(i, 3)) Then
          ini = a(i, 3)
          fin = a(i, 3)
        End If
      End If
    Else
      ini = 1
      fin = 1
    End If
    
    For j = ini To fin
      k = k + 1
      b(k, 1) = a(i, 1)
      b(k, 2) = a(i, 2)
      b(k, 3) = IIf(j = 1, "", j)
      b(k, 4) = a(i, 4)
    Next j
  Next i
  
  sh1.Range("G3").Resize(k, 4).Value = b
  sh2.Delete
  Application.ScreenUpdating = True

End Sub

 

[DanteAmor]

Sorry, another update.

With the data you gave me, it works for me, but apparently in the total of your data you have something that the macro does not consider, so try the following update:

Sub split_year()
  Dim a As Variant, b As Variant
  Dim i As Long, j As Long, k As Long, lr As Long
  Dim nMin As Double, nMax As Double, ini As Long, fin As Long
  Dim sh1 As Worksheet, sh2 As Worksheet
  
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  
  Set sh1 = Sheets("Tab1")
  sh1.Copy after:=Sheets(Sheets.Count)
  Set sh2 = ActiveSheet

  lr = sh2.Range("A:D").Find("*", , xlValues, xlPart, xlByRows, xlPrevious).Row

  With sh2.Range("C3:C" & lr).SpecialCells(xlCellTypeBlanks)
    .Formula = "=IF($B" & .Cells(1).Row & "="""",C" & .Cells(1).Row - 1 & ","""")"
    sh2.Range("C3:C" & lr).Copy
    sh2.Range("C3").PasteSpecial xlPasteValues
  End With
  
  With sh2.Range("B3:B" & lr).SpecialCells(xlCellTypeBlanks)
    .Formula = "=IF($A" & .Cells(1).Row & "="""",B" & .Cells(1).Row - 1 & ","""")"
    sh2.Range("B3:B" & lr).Copy
    sh2.Range("B3").PasteSpecial xlPasteValues
  End With

  With sh2.Range("A3:A" & lr).SpecialCells(xlCellTypeBlanks)
    .Formula = "=A" & .Cells(1).Row - 1
    sh2.Range("A3:A" & lr).Copy
    sh2.Range("A3").PasteSpecial xlPasteValues
  End With
  
  Application.CutCopyMode = False
  a = sh2.Range("A3", Range("F" & lr)).Value2
  ReDim b(1 To UBound(a, 1) * 80, 1 To 4)
  
  For i = 1 To UBound(a, 1)
    ini = 1
    fin = 1
    If a(i, 3) <> "" Then
      If InStr(a(i, 3), "-") Then
        ini = Val(Split(a(i, 3), "-")(0))
        fin = Val(Split(a(i, 3), "-")(1))
      Else
        If IsNumeric(a(i, 3)) Then
          ini = a(i, 3)
          fin = a(i, 3)
        End If
      End If
    End If
    
    For j = ini To fin
      k = k + 1
      b(k, 1) = a(i, 1)
      b(k, 2) = a(i, 2)
      b(k, 3) = IIf(j = 1, "", j)
      b(k, 4) = a(i, 4)
    Next j
  Next i
  
  sh1.Range("G3").Resize(k, 4).Value = b
  sh2.Delete
  Application.ScreenUpdating = True

End Sub

 

[DanteAmor]

A small change, this will speed up the execution.

Sub split_year()
  Dim a As Variant, b As Variant
  Dim i As Long, j As Long, k As Long, lr As Long
  Dim ini As Long, fin As Long
  Dim sh1 As Worksheet, sh2 As Worksheet
 
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
 
  Set sh1 = Sheets("Tab1")
  sh1.Copy after:=Sheets(Sheets.Count)
  Set sh2 = ActiveSheet
  lr = sh2.Range("A:D").Find("*", , xlValues, xlPart, xlByRows, xlPrevious).Row

  With sh2.Range("C3:C" & lr)
    With .SpecialCells(xlCellTypeBlanks)
      .Formula = "=IF($B" & .Cells(1).Row & "="""",C" & .Cells(1).Row - 1 & ","""")"
    End With
    .Value = .Value
  End With
 
  With sh2.Range("B3:B" & lr)
    With .SpecialCells(xlCellTypeBlanks)
      .Formula = "=IF($A" & .Cells(1).Row & "="""",B" & .Cells(1).Row - 1 & ","""")"
    End With
    .Value = .Value
  End With

  With sh2.Range("A3:A" & lr)
    With .SpecialCells(xlCellTypeBlanks)
      .Formula = "=A" & .Cells(1).Row - 1
    End With
    .Value = .Value
  End With
 
  a = sh2.Range("A3", Range("F" & lr)).Value2
  ReDim b(1 To UBound(a, 1) * 80, 1 To 4)
 
  For i = 1 To UBound(a, 1)
    ini = 0
    fin = 0
    If a(i, 3) <> "" Then
      ini = Val(Split(a(i, 3), "-")(0))
      fin = Val(Split(a(i, 3) & "-" & a(i, 3), "-")(1))
    End If
   
    For j = ini To fin
      k = k + 1
      b(k, 1) = a(i, 1)
      b(k, 2) = a(i, 2)
      b(k, 3) = IIf(j = 0, "", j)
      b(k, 4) = a(i, 4)
    Next j
  Next i
 
  sh1.Range("G3").Resize(k, 4).Value = b
  sh2.Delete
  Application.ScreenUpdating = True
End Sub

 

[Peter_SSs]

Hi Peter, thanks for the proposal, I will consider it.

As it turns out I think my proposal will not be sufficient. I hadn't looked closely enough at the new data to note that some data (eg row 20 in post 4) does not have any date value at all. Also post 13 seems to indicate another issue, yet unresolved.

 

[DanteAmor]

As it turns out I think my proposal will not be sufficient.

Actually, your proposal does work, with a little adaptation. I tried it in post # 17 and it works even if there are texts instead of years:

 

[Peter_SSs]

Here is my attempt. Assumes data in columns A:D, results in columns F:I

Sub SplitIt()
  Dim a As Variant, b As Variant
  Dim i As Long, k As Long, m As Long, Lastrow As Long, r As Long, NumVersions As Long
  Dim Make As String, Model As String, Years As String, Version As String
  
  Const Firstrow As Long = 3  '<- First row of actual data. Edit if required
  
  Columns("F:I").ClearContents
  Lastrow = Columns("A:D").Find(What:="*", LookIn:=xlValues, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
  a = Range("A" & Firstrow, Range("D" & Lastrow + 1)).Value
  ReDim b(1 To Rows.Count, 1 To 4)
  i = 1
  Do
    If a(i, 1) <> "" Then Make = a(i, 1)
    If a(i, 2) <> "" Then Model = a(i, 2)
    Years = "1"
    If Len(a(i, 3)) > 0 Then
      If IsNumeric(Split(a(i, 3), "-")(0)) And IsNumeric(Split(a(i, 3) & "-" & a(i, 3), "-")(1)) Then Years = a(i, 3)
    End If
    NumVersions = 1
    Do Until a(i + NumVersions, 1) & a(i + NumVersions, 2) & a(i + NumVersions, 3) <> "" Or a(i + NumVersions, 4) = ""
      NumVersions = NumVersions + 1
    Loop
    For k = Split(Years, "-")(0) To Split(Years & "-" & Years, "-")(1)
      For m = 0 To NumVersions - 1
        Version = a(i + m, 4)
        r = r + 1
        b(r, 1) = Make
        b(r, 2) = Model
        b(r, 3) = IIf(k = 1, "", k)
        b(r, 4) = Version
      Next m
    Next k
    i = i + NumVersions
  Loop Until i >= UBound(a)
  Range(Replace("F#:I#", "#", Firstrow)).Resize(r).Value = b
End Sub