I have code which creates a summary table from a bunch of excel files. The code copies and uses xlPasteSpecialOperationAdd to paste the selected range from each files to a temporary sheet.
The summary table has 2 input cells which determines the conditions. The 1st cell contains the statuses which can be [ALL, 0,1,2,3,4,5]. The 2nd field is the date in yyyy/mm/dd format.
The first cell recommended to fill, the second is optional. If the 2nd cell is empty then the date is doesn’t matter.
I think I have some trouble comparing the dates or probably the conditions incorrect. For comparing the dates I used two functions: LIKE and StrComp, but none of them worked or maybe because of the incorrect condition.
Please help me how to fix this code:
Set input cell text to string variable (2016.07 = 7 chars with dots):
'Get input date as string
AstrDate = OutputWs.Range("P5").Text
'Set the date to year and month format
AstrDateChars = Left$(strDate, 7)
Decide if the cell is blank:
'if the input range is blank then rangeBlank is true
If IsEmpty(OutputWs.Range("P5")) = True Then
rangeBlank = True
Else
rangeBlank = False
End If
'Get the output date to compare with
BstrDate = oNewBook.Sheets(1).Range("R22").Text
Get the output value:
'Set the compared date to year and month format
BstrDateChars = Left$(strDate, 7)
Comparing with StrComp function and store value into a boolean variable:
'compare date strings
'compareResult = StrComp(AstrDateChars, BstrDateChars, vbBinaryCompare)
Comparing with Like function:
compareResult = AstrDateChars Like BstrDateChars
The conditions:
'Which IL status you want to copy?
If inputValue = "ALL" And rangeBlank = True Then 'Search for all IL status
oNewBook.Worksheets(1).Range("G25:N28").Copy
tempWS.Range("G25:N28").PasteSpecial Paste:=xlPasteAll, operation:=xlPasteSpecialOperationAdd
oNewBook.Close
ElseIf inputValue = outputValue And rangeBlank = True Then 'Search for only the selected IL status
oNewBook.Worksheets(1).Range("G25:N28").Copy
tempWS.Range("G25:N28").PasteSpecial Paste:=xlPasteAll, operation:=xlPasteSpecialOperationAdd
oNewBook.Close
ElseIf inputValue = "ALL" And rangeBlank = False And compareResult = True Then 'Searcg ALL IL status and date
oNewBook.Worksheets(1).Range("G25:N28").Copy
tempWS.Range("G25:N28").PasteSpecial Paste:=xlPasteAll, operation:=xlPasteSpecialOperationAdd
oNewBook.Close
ElseIf inputValue = "ALL" And rangeBlank = False And compareResult = False Then 'Searcg ALL IL status and date, If date does not match, then closes the document
oNewBook.Close
ElseIf inputValue = outputValue And rangeBlank = False And compareResult = True Then 'Search for the selected IL0-IL5 and date
oNewBook.Worksheets(1).Range("G25:N28").Copy
tempWS.Range("G25:N28").PasteSpecial Paste:=xlPasteAll, operation:=xlPasteSpecialOperationAdd
oNewBook.Close
ElseIf inputValue = outputValue And rangeBlank = False And compareResult = False Then 'Search for the selected IL0-IL5 and date, if date does not match, then closes the document
oNewBook.Close
End If
Try this for StrComp:
compareResult = (StrComp(AstrDateChars, BstrDateChars, vbBinaryCompare)=0)
Related
I am trying to set cell "H2" to either "Shift 1" , "Shift 2" or "Shift 3" depending on the inputted time value found in Cell D2 of my workbook, here is a screenshot example:
So Cell H2 is Shift 1 because it's within a Timevalue of Case TimeValue("11:21 PM") To TimeValue("7:20 AM")
Here is the code, it executes but doesn't select a case and I can't figure out my mistake. Also, if there is anyway to execute these 3 case statements within the With statement as I set the time input in cell "D2" inside of that with statement I would appreciate that!
.Range("D2").Value = Now 'Inputs the Time Value as the current Time
.Range("D2").NumberFormat = "h:mm:ss AM/PM" 'Formats the Time value as a Time entry
The code can be found below:
Sub ReportGeneratorTest()
Application.ScreenUpdating = False 'This speeds up the macro by hiding what the macro is doing
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Set wb3 = Workbooks.Open(Filename:="\\Report Generator\SetupSheet Report Generator.xlsm") 'Sets the Workbook variable as the database filepath
With wb3.Sheets("All Requests Sheet 1") 'With the "Changes" sheet do the following
.Rows("2:2").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromRightOrBelow 'Inserts a new row in [3] with the same format as below
.Range("A2").Value = Sheet1.Range("K112").Value 'Inputs the typed in Operator name into the Report Generator
.Range("B2").Value = Sheet1.Range("H4").Value 'Inputs the "Key" inside cell "A" of the new row
.Range("C2").Value = Now 'Inputs the Date Submitted value as the current date
.Range("C2").NumberFormat = "dd-mmm-yyyy" 'Formats the Date Submitted value as a date entry
.Range("D2").Value = Now 'Inputs the Time Value as the current Time
.Range("D2").NumberFormat = "h:mm:ss AM/PM" 'Formats the Time value as a Time entry
.Range("E2").Value = UCase(Sheet1.Range("E4").Value) 'Inputs the Part inside Cell "D" of the new row
.Range("F2").Value = Sheet1.Range("E5").Value 'Inputs the Process inside Cell "E" of the new row
.Range("G2").Value = "IRR 200-2S"
End With
Dim T1 As Date
'T1 = Range("D2").Value
T1 = Now
'Set T1 = Range("D2").Value
Select Case T1
Case TimeValue("7:21 AM") To TimeValue("3:20 PM")
Range("H2").Value = "Shift 2"
Case TimeValue("3:21 PM") To TimeValue("11:20 PM")
Range("H2").Value = "Shift 3"
Case Else 'If the Timevalue is between TimeValue("11:21 PM") To TimeValue("7:20 AM")
Range("H2").Value = "Shift 1"
End Select
wb3.Save 'Save the database Workbook
wb3.Close False
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
Application.ScreenUpdating = True 'Must be "True" after running the code to be able to Read/Write the Workbook
End Sub
Summarizing the comments into an answer:
Case TimeValue("11:21 PM") To TimeValue("7:20 AM") doesn't work because when using To, the smaller value should come first. Maybe just move the "Shift 1" logic to a Case Else.
More importantly, Now includes today's date, i.e. it has both a day and time component. To get only the time component, you could do the following:
Dim T1 As Double
T1 = Now - Date
I'm trying to compare the value of a cell with entire column till there is a data, I'm unable to produce the correct result as only last value from the loop will be placed in the cell and also need to show the count of mis-matched result in other cell.
Sub test_blank()
Dim i As Integer, da As Long
da = Range("a2", Range("a15000").End(xlUp)).Count
For i = 1 To da
If Range("A" & i).Value = Range("b2").Value Then
Range("b3") = "match"
Else
Range("b3") = "does not match"
End If
Next
End Sub
I think what you are trying to achieve could be done like this
Sub test_blank()
Dim count As Integer
Dim doesntMatch As Boolean
'Set a counter for the number of times it doesn't match
count = 0
'Set a flag if a value doesn't match
doesntMatch = False
'Go through each cell in the column (starting from A2)
For Each cell In Range("A2", "A" & Cells(Rows.count, 1).End(xlUp).Row)
'If the value is found write match and leave the loop
If (cell <> Range("B2").Value) Then
doesntMatch = True
count = count + 1
End If
Next cell
'If a value didn't match at some point
If (doesntMatch) Then
'Display "Doesn't match" and the counter
Range("B3").Value = "Doesn't match"
Range("C3").Value = count
'If always matched
Else
'Display "Match"
Range("B3").Value = "Match"
End If
End Sub
Logic used
Checking every cell
If the cell doesn't match, increment the counter and activate the flag
If the flag is activated
Display the message and the counter
If the flag isn't activated
Display the message
I'm trying to code a macro that will sum data based off a user-input date range. I've got the code worked out to get the user input range and verify that it is a date, as well as convert it to match the syntax of the headers in my data file, but I'm having trouble figuring out how to sum only the months within that date range, with the date range subject to change every time the macro is run.
Here is a screenshot of the workbook. If the user inputs 1/1/16 and 3/31/16, I need the "Sum of Qty" to be a sum of the qty for January, February and March 2016. The same needs to occur for "Sum of Cost." There are multiple tables on the same sheet where this needs to happen and more tables, months, and columns will continue to be added.
Here is a link to the file, if you'd like to see formatting: https://www.dropbox.com/s/bc5okk684livm3a/TestFile_DateSum.xlsx?dl=0
And here is my existing code:
Sub DateRange()
Dim dateString As String, TheDate As Date
Dim dateString2 As String, TheDate2 As Date
Dim valid As Boolean: valid = True
Dim valid2 As Boolean: valid2 = True
Do
dateString = Application.InputBox("Enter Start Date in xx/xx/xx format: ")
If IsDate(dateString) Then
TheDate = DateValue(dateString)
valid = True
Else
MsgBox "Invalid date"
valid = False
End If
Loop Until valid = True
Do
dateString2 = Application.InputBox("Enter End Date in xx/xx/xx format: ")
If IsDate(dateString2) Then
TheDate2 = DateValue(dateString2)
valid2 = True
Else
MsgBox "Invalid date"
valid2 = False
End If
Loop Until valid2 = True
Application.Calculation = xlManual
[C3] = TheDate
[C4] = TheDate2
StartMonth = Month(TheDate) & "/1/" & Year(TheDate)
EndMonth = Month(TheDate2) & "/1/" & Year(TheDate2)
'Application.Calculate
'Application.Calculation = xlAutomatic
End Sub
Any help would be greatly appreciated!
I'm trying to get VBA to evaluate a formula as it goes over a loop. The portion that fails is the Evaluate() function itself, or at least the syntax I'm using.
Worksheets("Sheet2").Range("C2").Offset(All, 0) = _
Evaluate("((SUMPRODUCT(SUBTOTAL(2,OFFSET(PercentMet!$I$2,ROW(PercentMet!$I$2:$I$27301)-ROW(PercentMet!$H$2),0)),PercentMet!$I$2:$I$27301,PercentMet!$G$2:$G$27301)/SUMPRODUCT(SUBTOTAL(9,OFFSET(PercentMet!$G$2,ROW(PercentMet!$G$2:$G$27301)-ROW(PercentMet!$G$2),0)),--(PercentMet!$I$2:$I$27301<>""NA""))))")
The portion that fails is the ""NA"" at the end of the formula. Using this formula each cell equates to #VALUE!
If I remove the Evaluate portion the formula works as I want, but I need Evaluate because I'm looping through various filters and each value is unique.
Entire Code is Below:
Sub EthFilter()
Application.ScreenUpdating = False
Dim EthName As Range, GradeName As Range, Rate As Variant, Grade As Variant
Dim One As Integer, Zero As Integer, All As Integer
Set EthName = Worksheets("Sheet2").Range("J1")
Set GradeName = Worksheets("Sheet2").Range("K1")
One = 0
All = 0
For Each Raeth In Range("J1:J7")
Zero = 0
Rate = EthName.Offset(One, 0)
With Worksheets("PercentMet")
.AutoFilterMode = False
With .Range("$A$1:$O$27301")
.AutoFilter Field:=6, Criteria1:=Rate
For Each Grades In Range("B2:B9")
Grade = GradeName.Offset(Zero, 0).Value
With Worksheets("PercentMet")
With .Range("$A$1:$O$27301")
.AutoFilter Field:=5, Criteria1:=Grade
Worksheets("Sheet2").Range("C2").Offset(All, 0) = _
Evaluate("((SUMPRODUCT(SUBTOTAL(2,OFFSET(PercentMet!$I$2,ROW(PercentMet!$I$2:$I$27301)-ROW(PercentMet!$H$2),0)),PercentMet!$I$2:$I$27301,PercentMet!$G$2:$G$27301)/SUMPRODUCT(SUBTOTAL(9,OFFSET(PercentMet!$G$2,ROW(PercentMet!$G$2:$G$27301)-ROW(PercentMet!$G$2),0)),--(PercentMet!$I$2:$I$27301<>""NA""))))")
End With
End With
All = All + 1
Zero = Zero + 1
Next Grades
End With
End With
One = One + 1
Next Raeth
Application.ScreenUpdating = True
End Sub
If the length of the formula is a problem then instead of this (line breaks added for clarity):
Worksheets("Sheet2").Range("C2").Offset(All, 0) = Evaluate(
"((SUMPRODUCT(SUBTOTAL(2,OFFSET(PercentMet!$I$2,ROW(PercentMet!$I$2:$I$27301)-
ROW(PercentMet!$H$2),0)),PercentMet!$I$2:$I$27301,PercentMet!$G$2:$G$27301)/
SUMPRODUCT(SUBTOTAL(9,OFFSET(PercentMet!$G$2,ROW(PercentMet!$G$2:$G$27301)-
ROW(PercentMet!$G$2),0)),--(PercentMet!$I$2:$I$27301<>""NA""))))")
you can use this form:
Worksheets("Sheet2").Range("C2").Offset(All, 0) = Worksheets("PercentMet").Evaluate(
"((SUMPRODUCT(SUBTOTAL(2,OFFSET($I$2,ROW($I$2:$I$27301)-
ROW($H$2),0)),$I$2:$I$27301,$G$2:$G$27301)/
SUMPRODUCT(SUBTOTAL(9,OFFSET($G$2,ROW($G$2:$G$27301)-
ROW($G$2),0)),--($I$2:$I$27301<>""NA""))))")
Since all the inputs come from the same sheet you can use that sheet's Evaluate method and the formula will be evaluated in the context of that sheet.
The default Application.Evaluate version uses whichever sheet is Active at the time of execution.
I have code to check through a range for a cell value, and then paste the cell to the left in a different location. HOWEVER, I can not seem to figure out what to do if the range contains a value multiple times.
What I would like to do is if it contains a value twice (probably the maximum I will need to deal with) it will copy and paste each cell to the left in 2 different locations.
This is what I have right now:
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Cancel = True
Set OtherRng = Range("A18:S42")
Set NewRng = Range("C18:C60")
If Not Intersect(Target, OtherRng) Is Nothing Then
For Each cell In NewRng.Cells
If cell.Value = "41/N" Then
Map.Cells(35, 18).Value = cell.Offset(0, -1)
End If
If cell.Value = "41/M" Then
Map.Cells(35, 16).Value = cell.Offset(0, -1)
End If
Next
End sub
How can I make it so that if there are two values in NewRngthat both contain "41/N" that it puts the cell.offset(0,-1) for the first value into Map.cells(35,18) (like it does now) and the cell.offset(0,-1) for the second value into Map.cells(36,18)?
Try this:
dim i as integer
i = 0
For Each cell In NewRng.Cells
If cell.Value = "41/N" Then
Map.Cells(35+i, 18).Value = cell.Offset(0, -1)
i = i + 1
End If
There are better ways but for simplicity the above should do what you requested
I'm not certain of the VBA syntax, but you can keep a flag (or a counter) that you set (or increment) each time you see the given value. Then you select the cell to place the value in based off of the flag (or counter).
PseudoCode:
Seen_N = False
Seen_M = False
For Each cell in NewRng.Cells
If cell.Value = "41/N" Then
If Seen_N Then
Map.Cells(36,18).Value = cell.Offset(0,-1)
Else
Map.Cells(35,18).Value = cell.Offset(0,-1)
Seen_N = True
End If
End If
If cell.Value = "41/M" Then
If Seen_M Then
Map.Cells(36,16).Value = cell.Offset(0,-1)
Else
Map.Cells(35,16).Value = cell.Offset(0,-1)
Seen_M = True
End If
End If
Next
This should be fine if this is just a one-off, but if you did want to consider the case where you have lots of those entries, use a counter and calculate the row from the counter (I.e. row = 35+ num_Seen_N.