Split a year range into one row per year

Some videos you may like

Excel Facts

Will the fill handle fill 1, 2, 3?
Yes! Type 1 in a cell. Hold down Ctrl while you drag the fill handle.

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
12,542
Office Version
2007
Platform
Windows
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

Well-known Member
Joined
Dec 3, 2018
Messages
12,542
Office Version
2007
Platform
Windows
Try this update.
You could try a sample like the one you gave me. With 500 records.

VBA Code:
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

Well-known Member
Joined
Dec 3, 2018
Messages
12,542
Office Version
2007
Platform
Windows
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:

VBA Code:
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

Well-known Member
Joined
Dec 3, 2018
Messages
12,542
Office Version
2007
Platform
Windows
A small change, this will speed up the execution.

VBA Code:
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
 
Last edited:

Peter_SSs

MrExcel MVP, Moderator
Joined
May 28, 2005
Messages
45,918
Office Version
365
Platform
Windows
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

Well-known Member
Joined
Dec 3, 2018
Messages
12,542
Office Version
2007
Platform
Windows
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:

1599617243327.png
 

Peter_SSs

MrExcel MVP, Moderator
Joined
May 28, 2005
Messages
45,918
Office Version
365
Platform
Windows
Here is my attempt. Assumes data in columns A:D, results in columns F:I

VBA Code:
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
 

Subscribe on YouTube

Watch MrExcel Video

Forum statistics

Threads
1,105,857
Messages
5,507,756
Members
408,647
Latest member
Nicho la zido

This Week's Hot Topics

Top