Is your cloud always on? With an Always On cloud you won't have to worry about downtime for maintenance or software application code updates, ensuring that your bottom line isn't affected.
Become a Premium Member and unlock a new, free course in leading technologies each month.
Add your voice to the tech community where 5M+ people just like you are talking about what matters.
Sub Sample()
Dim ws As Worksheet
Dim LastRow As Long
Dim Temp, x As Long
Set ws = Sheets("Goga Tora")
LastRow = ws.Range("D" & Rows.Count).End(xlUp).Row
For i = 2 To LastRow
x = 7
Temp = ws.Range("D" & i).Value
If Len(Trim(Temp)) <> 0 Then
If Temp < 2001 Then
ws.Cells(i, x).Value = Temp
Else
Do While Temp > 2000
Temp = Temp - 2000
ws.Cells(i, x).Value = 2000
x = x + 4
Loop
If Temp < 2001 Then ws.Cells(i, x).Value = Temp
End If
End If
Next
End Sub
Consolidate1.xls
Sub Sample()
Dim ws As Worksheet
Dim LastRow As Long
Dim Temp, x As Long, i As Long
Set ws = Sheets("Goga Tora")
LastRow = ws.Range("D" & Rows.Count).End(xlUp).Row
For i = 2 To LastRow
x = i
Temp = ws.Range("D" & i).Value
If Len(Trim(Temp)) <> 0 Then
If Temp < 2001 Then
ws.Cells(i, 7).Value = Temp
Else
Do While Temp > 2000
Temp = Temp - 2000
ws.Cells(x, 7).Value = 2000
x = x + 1
Loop
If Temp < 2001 Then ws.Cells(x, 7).Value = Temp
End If
End If
Next
LastRow = ws.Range("G" & Rows.Count).End(xlUp).Row
ws.Range("G2:G" & LastRow).Copy
ws.Range("K2,O2,S2,W2,AA2,AE2").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
End Sub
Consolidate1.xls
Private Sub Worksheet_Change(ByVal Target As Range)
Dim ws As Worksheet
Dim LastRow As Long
Dim Temp, x As Long, i As Long
LastRow = Range("D" & Rows.Count).End(xlUp).Row
Application.ScreenUpdating = False
Application.EnableEvents = False
If Not Intersect(Target, Range("B2:B" & LastRow)) Is Nothing Then
x = Target.Row
Temp = Target.Offset(, 2).Value
If Len(Trim(Temp)) <> 0 Then
If Temp < 2001 Then
Cells(i, 7).Value = Temp
Else
Do While Temp > 2000
Temp = Temp - 2000
Cells(x, 7).Value = 2000
x = x + 1
Loop
If Temp < 2001 Then Cells(x, 7).Value = Temp
End If
End If
LastRow = Range("G" & Rows.Count).End(xlUp).Row
Range("G" & Target.Row & ":G" & x).Copy
Range("K" & Target.Row & ",O" & Target.Row & ",S" & Target.Row & ",W" & Target.Row _
& ",AA" & Target.Row & ",AE" & Target.Row).PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Range("F" & Target.Row).AutoFill Destination:=Range("F" & Target.Row & ":F" & x), Type:=xlFillDefault
Range("H" & Target.Row & ":J" & Target.Row).AutoFill Destination:=Range("H" & Target.Row & ":J" & x)
Range("L" & Target.Row & ":N" & Target.Row).AutoFill Destination:=Range("L" & Target.Row & ":N" & x)
Range("P" & Target.Row & ":R" & Target.Row).AutoFill Destination:=Range("P" & Target.Row & ":R" & x)
Range("T" & Target.Row & ":V" & Target.Row).AutoFill Destination:=Range("T" & Target.Row & ":V" & x)
Range("X" & Target.Row & ":Z" & Target.Row).AutoFill Destination:=Range("X" & Target.Row & ":Z" & x)
Range("AB" & Target.Row & ":AD" & Target.Row).AutoFill Destination:=Range("AB" & Target.Row & ":AD" & x)
Range("AF" & Target.Row & ":AG" & Target.Row).AutoFill Destination:=Range("AF" & Target.Row & ":AG" & x)
dt = Range("E" & Target.Row).Value
For i = Target.Row + 1 To x
dt = dt + 1
If Left(WeekdayName(Weekday(dt)), 3) = "Sat" Then
dt = dt + 2
ElseIf Left(WeekdayName(Weekday(dt)), 3) = "Sun" Then
dt = dt + 1
End If
Cells(i, 5).Value = dt
Next
End If
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
Consolidate1.xls
Option Explicit
Sub Sample()
Dim ws As Worksheet
Dim LastRow As Long
Dim Temp, x As Long, i As Long, j As Long
Dim dt As Date
Set ws = Sheets("Goga Tora")
With ws
LastRow = .Range("D" & Rows.Count).End(xlUp).Row
Application.ScreenUpdating = False
Application.EnableEvents = False
For i = 2 To LastRow
x = i
Temp = .Range("D" & i).Value
If Len(Trim(Temp)) <> 0 Then
If Temp < 2001 Then
.Cells(i, 7).Value = Temp
Else
Do While Temp > 2000
Temp = Temp - 2000
.Cells(x, 7).Value = 2000
x = x + 1
Loop
If Temp < 2001 Then .Cells(x, 7).Value = Temp
End If
.Range("G" & i & ":G" & x).Copy
.Range("K" & i & ",O" & i & ",S" & i & ",W" & i _
& ",AA" & i & ",AE" & i).PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
.Range("F" & i).AutoFill Destination:=.Range("F" & i & ":F" & x), Type:=xlFillDefault
.Range("H" & i & ":J" & i).AutoFill Destination:=.Range("H" & i & ":J" & x)
.Range("L" & i & ":N" & i).AutoFill Destination:=.Range("L" & i & ":N" & x)
.Range("P" & i & ":R" & i).AutoFill Destination:=.Range("P" & i & ":R" & x)
.Range("T" & i & ":V" & i).AutoFill Destination:=.Range("T" & i & ":V" & x)
.Range("X" & i & ":Z" & i).AutoFill Destination:=.Range("X" & i & ":Z" & x)
.Range("AB" & i & ":AD" & i).AutoFill Destination:=.Range("AB" & i & ":AD" & x)
.Range("AF" & i & ":AG" & i).AutoFill Destination:=.Range("AF" & i & ":AG" & x)
dt = .Range("E" & i).Value
For j = j + 1 To x
dt = dt + 1
If Left(WeekdayName(Weekday(dt)), 3) = "Sat" Then
dt = dt + 2
ElseIf Left(WeekdayName(Weekday(dt)), 3) = "Sun" Then
dt = dt + 1
End If
.Cells(j, 5).Value = dt
Next
End If
Next
End With
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
Consolidate1-1.xls
If you are experiencing a similar issue, please ask a related question
Join the community of 500,000 technology professionals and ask your questions.