So I am writing a case function that when an event (7 - Engaged) occurs an interactive textbox pops up asking the user to confirm this action. If they select OK the data is moved to another spreadsheet.
That all works dandy but probably needs revising to tidy it.
Anyways, the issue arises when the user selects cancel.
Instead of just leaving the function the line of data is deleted.
I believe this issue is the last couple lines deletes anything that is 7-engaged, but I haven't written a piece of code to bring the value down to 6 if the user cancels out.
Can anyone give me some hints?
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Source As Range)
' Maybe disable events whilst this code runs (and re-enable before exit)
' to prevent recursion.
' The three range rows are to move sepearate sections of data from pipeline into isolated blocks in tank.
If Source.Column <> 9 Then Exit Sub ' 9 = I
If Source.Cells.Count > 1 Then Exit Sub ' Check this first before making comparison on next line
If Source.Value <> "7 - engaged" Then Exit Sub
If MsgBox("Client status selected as engaged. Confirm to post to tank.", vbOKCancel) = vbOK Then
With ThisWorkbook.Worksheets("Tank") 'Produces an interactive dialoge box prompting the user to confirm they wish ti import to tank
'The code only fires if they confirm - if not, the line will remain in Pipeline.
Dim rowToPasteTo As Long
rowToPasteTo = .Cells(.Rows.Count, "B").End(xlUp).Row + 1
.Range("A" & rowToPasteTo & ":" & "D" & rowToPasteTo).Value = Sh.Range("A" & Source.Row & ":" & "M" & Source.Row).Value
.Range("G" & rowToPasteTo & ":" & "H" & rowToPasteTo).Value = Sh.Range("E" & Source.Row & ":" & "F" & Source.Row).Value
.Range("S" & rowToPasteTo & ":" & "U" & rowToPasteTo).Value = Sh.Range("K" & Source.Row & ":" & "M" & Source.Row).Value
End With
End If
If Source.Column = 9 And Source.Value = "7 - engaged" Then
Source.EntireRow.Delete
' The above line deleted the row from pipeline once it has been imported in Tank
End If
End Sub
I have now added this piece of code which negates the problem.
If MsgBox("Client status selected as engaged. Confirm to post to tank.", vbOKCancel) = vbCancel Then
Source.Value = "6 - KYC in progress" ' If cancel is selected the value goes back to Case 6 and the line is kept.
End If
Related
Good day all,
i am looking to alter the below VBA Code to send reminder to filtered range to each User based on specific text in column "H" "Send Reminder" and filtered range must be pasted into email below the body lines (Means Column A1:E1 by User wise filtered range).
Basically VBA code will reduce our work from more than hours to Milli seconds.
Problems encountered:
in our daily work we have so many todo list which needs to remind employee by employee wise with filtered list to each person will consume more than 2 hours to sort our data. Now the below code works but not filtered by User wise so its completely insufficient to use it properly. sending each email wise but filtered table also needs to place in the body of the emails is worthy. Hence time does not reduce much more than that.
Hence i am Looking to alter the below code as per my requirement.
Existing VBA Code:
Sub Send_Reminder()
Dim wStat As Range, i As Long
Dim dam As Object
For Each wStat In Range("H2", Range("H" & Rows.Count).End(xlUp))
If wStat.Value = "Send Reminder" Then
i = wStat.Row
Set dam = CreateObject("Outlook.Application").CreateItem(0)
dam.To = Range("I" & i).Value
dam.Cc = "" 'Range("F" & i).Value
dam.Subject = Range("B" & i).Value
dam.Body = "Hi " & Range("E" & i).Value & "," & vbCr & vbCr & _
"This is to remind you that " & Range("B" & wStat.Row).Value & " " & _
"Report is due today." & vbCr & vbCr & _
"Cheers!"
dam.FlagRequest = "Follow up" ' We set the Follow up Flag
dam.FlagDueBy = Format(DateAdd("d", 1, Date) + TimeValue("09:30:00"), "dd/mm/yyyy hh:mm") ' We set the due date for the reminder two days from today
dam.Display '.Sent
'
dam.Display '.Send
wStat.Value = "Sent"
End If
Next
MsgBox "Emails Sent"
End Sub
Not the best at VBA but I will give some context to help explain this probably stupid question.
The place I work for has a terrible system so we tend to do things our own way and use the system as little as possible.
We wanted to be able to take direct debits from customers as and when we need to and to do this we needed to create a 'BACS Standard 18' file to upload to the bank in order to collect the direct debits. The file requires there to be specific information about the transaction and it has to be displayed in a very specific way in notepad(txt).
I managed to create an Excel file that our finance team can use in order to create the file but when the file is created the typing cursor is always found to be a couple of lines under the exported text.
I need the text to be exported and the typing cursor to be at the end of the last line of the text, or a least not underneath. If it is under it, the bank will see that as a blank line and not accept the file. The number of lines in the file will always be different as well.
I have attached an example of the file in a screenshot. The highlighted part is what the file should include but as you can see the typing cursor is two lines lower.
Can someone please help with this and explain where I have gone wrong.
Thank you.
exportedfile
Below is the [vba] used to build the file and export the data from excel to notepad:
Sub Build_BACS()
LastRow = (Worksheets("Input").Range("Q2"))
'Header
ActiveSheet.Range("A1").Value = "=""VOL1""&Home!D5&"" ""&Home!D2&"" ""&""1"""
ActiveSheet.Range("A2").Value = "=""HDR1A""&Home!D2&""S""&"" ""&Home!D5&""00010001 ""&Home!D8&"" ""&Home!E8&"" 000000 """
ActiveSheet.Range("A3").Value = "=""HDR2F02000""&Home!B11&"" 00 """
ActiveSheet.Range("A4").Value = "=""UHL1 ""&Home!D8&""999999 000000001 DAILY 001 """
'Middle
ActiveSheet.Range("A5").Value = "=CONCAT(Input!C2,Input!D2,Input!K2,Input!G2,Input!H2,"" "",Input!L2,Input!M2,"" "",Input!N2,Input!O2)"
On Error Resume Next
Range("A5").AutoFill Destination:=Range("A5:A" & LastRow + 4), Type:=xlFillDefault
'Footer
If Sheets("Home").Range("A2").Value = "TMR" Or Sheets("Home").Range("A2").Value = "TMRF" Or Sheets("Home").Range("A2").Value = "TMREA" Then
Sheets("Output").Range("A" & LastRow + 5).Value = "=TEXT(Home!C2,""000000"")&TEXT(Home!B2,""00000000"")&""099""&TEXT(Home!C2,""000000"")&TEXT(Home!B2,""00000000"")&"" ""&TEXT(Input!P2,""00000000000"")&""The Mailing Room CONTRA TMR """
ElseIf Sheets("Home").Range("A2").Value = "DPS" Then
Sheets("Output").Range("A" & LastRow + 5).Value = "=TEXT(Home!C2,""000000"")&TEXT(Home!B2,""00000000"")&""099""&TEXT(Home!C2,""000000"")&TEXT(Home!B2,""00000000"")&"" ""&TEXT(Input!P2,""00000000000"")&""DPS CONTRA TMR """
End If
ActiveSheet.Range("A" & LastRow + 6).Value = "=""EOF1""&MID(A2,5,76)"
ActiveSheet.Range("A" & LastRow + 7).Value = "=""EOF2""&MID(A3,5,76)"
ActiveSheet.Range("A" & LastRow + 8).Value = "=""UTL1""&TEXT(Input!P2,""0000000000000"")&TEXT(Input!P2,""0000000000000"")&""0000001""&TEXT(Input!Q2,""0000000"")&"" """
'Export
Dim c As Range
Dim r As Range
Dim output As String
For Each r In Range("A1:A" & LastRow + 8).Rows
For Each c In r.Cells
output = output & c.Value
Next c
output = output & vbNewLine
Next r
Open ThisWorkbook.Path & "\" & ([Indirect("Home!B13")]) & ".txt" For Output As #1
Print #1, output
Close
InputBox "Noice." & Chr(13) & "Your file is just in here", "File Path", "Z:\My Documents\Orrin Lesiw\Direct Debit\Convert File"
End Sub
Adding ; to Print suppressed the vbNewLine. However output = output & vbNewLine will always add a newline so either add to front for lines 2 onwards like
Sub out2()
Dim c As Range
Dim r As Range
Dim output As String
For Each r In Range("A1:A" & LastRow + 8).Rows
If r.Row > 1 Then output = output & vbNewLine
For Each c In r.Cells
output = output & c.Value
Next c
Next r
Open ThisWorkbook.Path & "\" & ([Indirect("Home!B13")]) & ".txt" For Output As #1
Print #1, output;
Close
End Sub
or transpose the range into an array and use Join
' Export
Dim ar
ar = Application.Transpose(Range("A1:A" & LastRow + 8))
Open ThisWorkbook.Path & "\" & ([Indirect("Home!B13")]) & ".txt" For Output As #1
Print #1, Join(ar, vbNewLine);
Close
I have a macro that moves some data around in different spreadsheets and I have been trying to figure out why my Debug.Print is not printing the long data. It prints the string but wont print the long.
The below code does not produce an error message and the data is moved as I would expect it to be however when I try to use a print statement to print to the Immediate window all I get is the string portion of the print.
I have tried to convert to string using CStr() on my long just in case it was a problem with concatenating non-string with string with no change in results. I have tried just printing the long by itself and all it prints is an empty line to the Immediate window.
My question is this:
Is there a reason for my code to not print the long?
I know the results of my MACRO do exactly what I need them to do by manually verify each step with breakpoints but why is Debug.Print not printing the long?
Example results from Debug.Print
Last Row for G90_CTR_WS:
Last Row for L90_CTR_WS:
Last Row for BU_WB:
Last Row for rng1:
Last Row for rng2:
Code:
On Error GoTo 0
lr_counter = inv_wb.Worksheets(7).Cells(Rows.Count, "A").End(xlUp).Row
Set rng1 = inv_wb.Worksheets(7).Range("A2:G" & lr_counter)
Debug.Print ("Last Row for G90_CTR_WS: " & lr__counter)
lr_counter = inv_wb.Worksheets(6).Cells(Rows.Count, "A").End(xlUp).Row
rng1.Cut Destination:=inv_wb.Worksheets(6).Range("A" & lr_counter + 1)
Debug.Print ("Last Row for L90_CTR_WS: " & lr__counter)
check_for_file = Dir(workbook_directory & "\*backup*")
Set bu_wb = Workbooks.Open(workbook_directory & "\" & check_for_file)
lr_counter = bu_wb.Worksheets(1).Cells(Rows.Count, "B").End(xlUp).Row
Set rng1 = bu_wb.Worksheets(1).Range("B2:B" & lr_counter)
Debug.Print ("Last Row for BU_WB: " & lr__counter)
bu_wb.Close SaveChanges:=False
lr_counter = inv_wb.Worksheets(6).Cells(Rows.Count, "A").End(xlUp).Row
Set rng2 = inv_wb.Worksheets(6).Range("A2:A" & lr_counter)
Debug.Print ("Last Row for rng1: " & lr__counter)
check_for_file = Dir(workbook_directory & "\*vehicle*list*")
Set vl_wb = Workbooks.Open(workbook_directory & "\" & check_for_file)
lr_counter = vl_wb.Worksheets(1).Cells(Rows.Count, "I").End(xlUp).Row
Set rng3 = vl_wb.Worksheets(1).Range("I2:I" & lr_counter)
Debug.Print ("Last Row for rng2: " & lr__counter)
Put Option Explicit and see where the code explodes. - Option Explicit
A way to have automatically written Option Explicit is to select "Require Variable Declaration" in the VBEditor>Tools>Options:
In general, I guess it is here:
lr_counter = inv_wb.Worksheets(7).Cells(Rows.Count, "A").End(xlUp).Row
Set rng1 = inv_wb.Worksheets(7).Range("A2:G" & lr_counter)
Debug.Print ("Last Row for G90_CTR_WS: " & lr__counter)
lr__counter is with 2 _ and is declared with 1.
I have a userform with textboxes txtTF1 – txtTF30 where odd numbers are a start date and even numbers are end dates. I’m using a calendar date picker and a (correctly functioning) logical test to help ensure the inputs are dates. I also want a logical test on the inputs to make sure I don’t have overlapping dates.
The code below correctly spots date overlap until it runs into textboxes that are intentionally left blank. Those blanks are set to vbnullstring when the form initializes. At this point something triggers the message box saying there is an overlap on the next to last set of dates even when I can see that is not true.
Debug.Print is showing that the last set of dates in the userform is not loading into the variables.
I’m not sure where/how this test breaks down. Any thoughts?
Sub OverlapCheck
Dim i as Long
Dim CheckDate1
Dim CheckDate2
Dim CheckDate3
For i = 2 To 28 Step 2
CheckDate1 = Controls("txtTF" & i).value
CheckDate2 = Controls("txtTF" & (i + 1)).value
CheckDate3 = Controls("txtTF" & (i - 1)).value
‘stop test if next date is blank
If Not IsDate(CheckDate2) Then Exit For
‘if a valid date range is entered then check to see if the next date is an overlap
If IsDate(CheckDate1) And IsDate(CheckDate3) Then
If CheckDate1 >= CheckDate2 Then
MsgBox ("Dates " & CheckDate1 & " and" & CheckDate2 & " overlap"), vbOKOnly
frmRLVL.Show
End If
End If
Next
End Sub
I got this to work with the addition of CDate() in the for/next statement. I'm still not sure why this makes it work on the last set of dates when input data ends where 2>i>28. At this point I'm calling it a win.
For i = 2 To 28 Step 2
CheckDate1 = Controls("txtTF" & i).value
CheckDate2 = Controls("txtTF" & (i - 1)).value
CheckDate3 = Controls("txtTF" & (i + 1)).value
If Not IsDate(CheckDate3) Then Exit For
If IsDate(CheckDate1) And IsDate(CheckDate2) Then
CheckDate1 = CDate(CheckDate1)
CheckDate2 = CDate(CheckDate2)
CheckDate3 = CDate(CheckDate3)
If CheckDate1 >= CheckDate3 Then
MsgBox ("Dates " & CheckDate1 & " and" & CheckDate3 & " overlap"), vbOKOnly
frmRLVL.Show
End If
End If
Next
I'm working on a 'dashboard' in excel where the user can select a commodity and then presses the run button, so the code then prints out all suppliers linked to that commodity. (Several commodities and supplier names are listed on other tabs in the same workbook, and the code goes over all tabs to collect the right supplier names)
EDIT: the issue is due to a supplier name being longer than 255 characters.
The debugger focuses on this code in particular:
If Application.Evaluate("COUNTIF(" & myDataRng.Address & "," & cell.Address & ")") > 1 Then
cell.Offset(0, 0).Font.Color = vbRed
End If
This code is part of the bigger set below. The code highlights all suppliernames that are listed under the chosen category in different tabs (hence they would be printed out multiple times, I want to highlight the duplicate values).
'##### Find duplicates in commodity column and highlight them ######
Dim myDataRng As Range
Dim cell As Range
Set myDataRng = Range("E10:E" & Cells(Rows.Count, "E").End(xlUp).Row)
For Each cell In myDataRng
cell.Offset(0, 0).Font.Color = vbBlack
If Application.Evaluate("COUNTIF(" & myDataRng.Address & "," & cell.Address & ")") > 1 Then
cell.Offset(0, 0).Font.Color = vbRed
End If
Next cell
Any idea what it could be?
The error is not immediately obvious. I made a few tweaks to the code, however this should allow you to see what's being evaluated. Typically you'd get this error from the formula not being entered with the correct format, but it works on my end.
I removed the Offset(0,0) as it is superfluous at present with no offset applied, as well as placing the vbBlack formatting in an Else block for performance/clarity.
However seeing the Debug.Print statement should be critical for understanding when the code is not functioning. The only other thought I have, is you may want to clarify which sheet this Countif is being completed on.
Update
I've revised my answer to use SumProduct instead of CountIf to workaround the issue of 255 characters being the limit for CountIf.
Public Sub TestSub()
Dim myDataRng As Range
Dim cell As Range
Dim EvalStr As String
Set myDataRng = Range("E10:E" & Cells(Rows.Count, "E").End(xlUp).Row)
For Each cell In myDataRng
EvalStr = "SumProduct((" & myDataRng.Address & "=" & cell.Address & ")+0)"
If Application.Evaluate(EvalStr) > 1 Then
cell.Font.Color = vbRed
Else
cell.Font.Color = vbBlack
End If
Next cell
End Sub
Change your line:
If Application.Evaluate("COUNTIF(" & myDataRng.Address & "," & cell.Address & ")") > 1 Then
With:
If Application.Evaluate("COUNTIF(" & myDataRng.Address & "," & cell.Address & " > 1 )") Then