gowflow
Step 1 By clicking Explore Button - see Date in cell C1 if date is greater or equal to D1 then red highlighted range I42:M42 i.e. 5 cell addresses - add +1 in each cell address in sheet LT.Z.
Step 3 New data in highlighted Cell I42:M42 same way +1 to sheet LT.Z....next i next I till 4 row data is available.
Step 3 process whole data from row 1 to row 108 but as one round over delete the one row oldest data & move up one row whole data so red highlighted result will change do the same as above.do this till we have four point data as my calculation (red highlighted) require 4 row data.
'---> Check to see if C1>D1
If DateValue(WSCal.Cells(1, "C")) > DateValue(WSCal.Cells(1, "D")) Then
What happen if in sheet calculation cell D1, date is 1 jun 2013 & data is available in column A B C is start from 1 jan 2013. it will delete the data till current date is leaser than data date & then proceed calculation? D1<C1,<= is not required as it may conflict & recalculate the same data. so I had
Sub Explore()
Dim WSCal As Worksheet
Dim WSLTZ As Worksheet
Dim MaxRowCal As Long, I As Long
'---> Set Variables
Set WSCal = ActiveSheet
MaxRowCal = WSCal.Range("A1").End(xlDown).Row
On Error Resume Next
Set WSLTZ = Sheets(Format(WSCal.Range("E1")))
If Err <> 0 Then
MsgBox ("Error occured and program will be halted." & Error(Err))
Exit Sub
End If
On Error GoTo 0
I = 0
'---> Start Process
Do While MaxRowCal > 4
'---> Check to see if C1>=D1
If DateValue(WSCal.Cells(1, "C")) > DateValue(WSCal.Cells(1, "D")) Then
'---> Assign Value of 1 to Existing Value in all of Red Cells
' in their coresponding cells in sheet LT.Z
If WSCal.Range("I42") <> "" Then WSLTZ.Range(WSCal.Range("I42").Value) = WSLTZ.Range(WSCal.Range("I42").Value) + 1
If WSCal.Range("J42") <> "" Then WSLTZ.Range(WSCal.Range("J42").Value) = WSLTZ.Range(WSCal.Range("J42").Value) + 1
If WSCal.Range("K42") <> "" Then WSLTZ.Range(WSCal.Range("K42").Value) = WSLTZ.Range(WSCal.Range("K42").Value) + 1
If WSCal.Range("L42") <> "" Then WSLTZ.Range(WSCal.Range("L42").Value) = WSLTZ.Range(WSCal.Range("L42").Value) + 1
If WSCal.Range("M42") <> "" Then WSLTZ.Range(WSCal.Range("M42").Value) = WSLTZ.Range(WSCal.Range("M42").Value) + 1
End If
'---> Move all data 1 row up for Col A to C
WSCal.Range("A2:C" & MaxRowCal).Copy WSCal.Range("A1")
WSCal.Range("A" & MaxRowCal & ":C" & MaxRowCal).ClearContents
MaxRowCal = WSCal.Range("A1").End(xlDown).Row
'---> Incr Counter
I = I + 1
Loop
MsgBox ("Exploring completed successfully for " & I & " Rows")
End Sub
Sub Explore()
Dim WSCal As Worksheet
Dim WSLTZ As Worksheet
Dim MaxRowCal As Long, I As Long
'---> Set Variables
Set WSCal = ActiveSheet
MaxRowCal = WSCal.Range("A1").End(xlDown).Row
On Error Resume Next
Set WSLTZ = Sheets(Format(WSCal.Range("E1")))
If Err <> 0 Then
MsgBox ("Error occured and program will be halted." & Error(Err))
Exit Sub
End If
On Error GoTo 0
I = 0
'---> Start Process
Do While MaxRowCal > 4
'---> Check to see if C1>=D1
If DateValue(WSCal.Cells(1, "C")) >= DateValue(WSCal.Cells(1, "D")) Then
'---> Assign Value of 1 to Existing Value in all of Red Cells
' in their coresponding cells in sheet LT.Z
If WSCal.Range("I42") <> "" Then WSLTZ.Range(WSCal.Range("I42").Value) = WSLTZ.Range(WSCal.Range("I42").Value) + 1
If WSCal.Range("J42") <> "" Then WSLTZ.Range(WSCal.Range("J42").Value) = WSLTZ.Range(WSCal.Range("J42").Value) + 1
If WSCal.Range("K42") <> "" Then WSLTZ.Range(WSCal.Range("K42").Value) = WSLTZ.Range(WSCal.Range("K42").Value) + 1
If WSCal.Range("L42") <> "" Then WSLTZ.Range(WSCal.Range("L42").Value) = WSLTZ.Range(WSCal.Range("L42").Value) + 1
If WSCal.Range("M42") <> "" Then WSLTZ.Range(WSCal.Range("M42").Value) = WSLTZ.Range(WSCal.Range("M42").Value) + 1
End If
'---> Move all data 1 row up for Col A to C
WSCal.Range("A2:C" & MaxRowCal).Copy WSCal.Range("A1")
WSCal.Range("A" & MaxRowCal & ":C" & MaxRowCal).ClearContents
MaxRowCal = WSCal.Range("A1").End(xlDown).Row
'---> Incr Counter
I = I + 1
Loop
'---> Copy Cell C1 in Calculation to Cell A1 in LT.Z
WSLTZ.Range("A1") = WSCal.Range("C1")
MsgBox ("Exploring completed successfully for " & I & " Rows")
End Sub
B)what if Cell C1 date is > cell D1. as in attached sheet i had manually put 22 may 2013. as per condition after that data should be processed ..(which is not processing ) & after that copy date of C1 & past to Sheet LT.Z A1 - End
Sub Explore()
Dim WSCal As Worksheet
Dim WSLTZ As Worksheet
Dim MaxRowCal As Long, I As Long
'---> Set Variables
Set WSCal = ActiveSheet
MaxRowCal = WSCal.Range("A1").End(xlDown).Row
On Error Resume Next
Set WSLTZ = Sheets(Format(WSCal.Range("E1")))
If Err <> 0 Then
MsgBox ("Error occured and program will be halted." & Error(Err))
Exit Sub
End If
On Error GoTo 0
I = 0
'---> Start Process
Do While MaxRowCal > 4
'---> Check to see if C1>D1
If DateValue(WSCal.Cells(1, "C")) > DateValue(WSCal.Cells(1, "D")) Then
'---> Assign Value of 1 to Existing Value in all of Red Cells
' in their coresponding cells in sheet LT.Z
If WSCal.Range("I42") <> "" Then WSLTZ.Range(WSCal.Range("I42").Value) = WSLTZ.Range(WSCal.Range("I42").Value) + 1
If WSCal.Range("J42") <> "" Then WSLTZ.Range(WSCal.Range("J42").Value) = WSLTZ.Range(WSCal.Range("J42").Value) + 1
If WSCal.Range("K42") <> "" Then WSLTZ.Range(WSCal.Range("K42").Value) = WSLTZ.Range(WSCal.Range("K42").Value) + 1
If WSCal.Range("L42") <> "" Then WSLTZ.Range(WSCal.Range("L42").Value) = WSLTZ.Range(WSCal.Range("L42").Value) + 1
If WSCal.Range("M42") <> "" Then WSLTZ.Range(WSCal.Range("M42").Value) = WSLTZ.Range(WSCal.Range("M42").Value) + 1
'---> Incr Counter
I = I + 1
End If
'---> Move all data 1 row up for Col A to C
WSCal.Range("A2:C" & MaxRowCal).Copy WSCal.Range("A1")
WSCal.Range("A" & MaxRowCal & ":C" & MaxRowCal).ClearContents
MaxRowCal = WSCal.Range("A1").End(xlDown).Row
Loop
'---> Copy Cell C1 in Calculation to Cell A1 in LT.Z
WSLTZ.Range("A1") = WSCal.Range("C1")
MsgBox ("Exploring completed successfully for " & I & " Rows")
End Sub
Do While MaxRowCal > 4
Do While MaxRowCal >= 4
I do not see any problem if you do this then you will endup with 3 rows not 4 is this ok with you ???
I just tried it and it ended up with 3 rows if this is fine with you then go ahead and do it.
TKs your kind comments. My pleasure to help.
PLs feel free to post here any link to any other question you feel you may need my help with.
Sub Explore()
Dim WSCal As Worksheet
Dim WSLTZ As Worksheet
Dim MaxRowCal As Long, I As Long
'---> Set Variables
Set WSCal = ActiveSheet
MaxRowCal = WSCal.Range("C1").End(xlDown).Row
On Error Resume Next
Set WSLTZ = Sheets(Format(WSCal.Range("E1")))
If Err <> 0 Then
MsgBox ("Error occured and program will be halted." & Error(Err))
Exit Sub
End If
On Error GoTo 0
I = 0
'---> Start Process
Do While MaxRowCal > 4
'---> Check to see if C1>D1
If DateValue(WSCal.Cells(1, "C")) > DateValue(WSCal.Cells(1, "D")) Then
'---> Assign Value of 1 to Existing Value in all of Red Cells
' in their coresponding cells in sheet LT.Z
If WSCal.Range("I42") <> "" Then WSLTZ.Range(WSCal.Range("I42").Value) = WSLTZ.Range(WSCal.Range("I42").Value) + 1
If WSCal.Range("J42") <> "" Then WSLTZ.Range(WSCal.Range("J42").Value) = WSLTZ.Range(WSCal.Range("J42").Value) + 1
If WSCal.Range("K42") <> "" Then WSLTZ.Range(WSCal.Range("K42").Value) = WSLTZ.Range(WSCal.Range("K42").Value) + 1
If WSCal.Range("L42") <> "" Then WSLTZ.Range(WSCal.Range("L42").Value) = WSLTZ.Range(WSCal.Range("L42").Value) + 1
If WSCal.Range("M42") <> "" Then WSLTZ.Range(WSCal.Range("M42").Value) = WSLTZ.Range(WSCal.Range("M42").Value) + 1
'---> Incr Counter
I = I + 1
End If
'---> Move all data 1 row up for Col A to C
WSCal.Range("A2:C" & MaxRowCal).Copy WSCal.Range("A1")
WSCal.Range("A" & MaxRowCal & ":C" & MaxRowCal).ClearContents
MaxRowCal = WSCal.Range("C1").End(xlDown).Row
Loop
'---> Copy Cell C1 in Calculation to Cell A1 in LT.Z
WSLTZ.Range("A1") = WSCal.Range("C1")
MsgBox ("Exploring completed successfully for " & I & " Rows")
End Sub
Title | # Comments | Views | Activity |
---|---|---|---|
Macro to Refresh the Hyperlinks without opening the source files | 1 | 37 | |
Excel - Row Height +1 VBA | 2 | 23 | |
AutoFilter Delete not keeping Headers? | 2 | 12 | |
Thanks for the advise, but... | 4 | 24 |
Join the community of 500,000 technology professionals and ask your questions.
Connect with top rated Experts
12 Experts available now in Live!