DanteAmor
Well-known Member
- Joined
- Dec 3, 2018
- Messages
- 12,542
- Office Version
- 2007
- Platform
- Windows
Hi Peter, thanks for the proposal, I will consider it.I think you could raplace this whole section of code
Hi Peter, thanks for the proposal, I will consider it.I think you could raplace this whole section of code
From 70 to 2020 is 50 years, I considered a range of 80 years, try the code from post #9I would say smallest year can be 1970. and biggest one is 2020.
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
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
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
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.Hi Peter, thanks for the proposal, I will consider it.
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:As it turns out I think my proposal will not be sufficient.
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