# Split a year range into one row per year

#### DanteAmor

##### Well-known Member
I think you could raplace this whole section of code
Hi Peter, thanks for the proposal, I will consider it.

### 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
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

##### New Member
there is another error now please see the screen shots attached

#### Attachments

• 166.2 KB Views: 3
• 3.5 KB Views: 3

#### DanteAmor

##### Well-known Member
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
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

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
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

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
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

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
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
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

##### MrExcel MVP, Moderator
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``````