Modern healthcare requires a modern cloud. View this brief video to understand how the Concerto Cloud for Healthcare can help your organization.
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.