I have a series of values on a sheet
E11: "Notional"
E12: "Strike"
E13: "Coupon"
Etc.
In my code, use the sheet name
Function AddInput(name As String, strInput As String, Optional suffix = "") As String
Dim inputVal As Variant
On Error GoTo ERROR_FUNCTION
With Worksheets(name)
If .Cells.Find(what:=strInput, LookAt:=xlWhole,searchorder:=xlByRows).Offset(0, 1).Value <> "" Then
inputVal = Trim(Cells.Find(what:=strInput, LookAt:=xlWhole, searchorder:=xlByRows).Offset(0, 1).Value)
If TypeName(inputVal) = "Date" Then inputVal = Format(inputVal, "YYYYMMDD")
AddInput = Replace(strInput, " ", "") & "=" & inputVal & "&"
If suffix <> "" Then AddInput = AddInput & suffix
Else
AddInput = ""
End If
End With
Exit Function
ERROR_FUNCTION:
Debug.Print strInput & ": input not found"
MsgBox strInput & ": input not found"
End Function
I am able to find whats in Cell E12, but not E11.
I have done the following:
1) I copied the cell value into the search function directly (No chance to fat-finger it).
2) I copied the values from E11 down 1 (if for some reason it couldn't find that range etc... it just returned E12).
I still cannot find that one cell, it works for every other value I put through it.
Has anyone encountered this, and how did you resolve it?
Thanks!
Make sure you start each search correctly:
Sub dural()
Dim r As Range
strSheetname = ActiveSheet.Name
MyInputString = Application.InputBox(Prompt:="Enter value", Type:=2)
With Sheets(strSheetname)
Set r = .Cells.Find(what:=MyInputString, After:=Range("A1"))
End With
MsgBox r.Address(0, 0)
End Sub
Related
I've been trying to find the first empty cell in Word table using VBA.
The code which I've put below finds all the empty cells instead I want to find the first one after filled one. How to solve this problem?
For Each oRow In Selection.Tables(1).Rows
For Each oCell In oRow.Cells
If Selection.Text = Chr(13) & Chr(7) Then
oCell.Select
'Selection.PasteSpecial DataType:=wdPasteText
MsgBox oCell.RowIndex & " " & oCell.ColumnIndex & " is empty."
End If
Next oCell
Next oRow
Is this what you had in mind?
Sub FindNextBlank()
Dim Tbl As Table
Dim TblRow As Row
Dim HasText As Boolean
Dim LookForText As Boolean, Done As Boolean
Dim R As Long, C As Long
Dim Txt As String
LookForText = True
With ThisDocument.Tables(1)
For R = 1 To .Rows.Count
Set TblRow = .Rows(R)
For C = 1 To TblRow.Cells.Count
HasText = (Len(TblRow.Cells(C).Range.Text) > 2)
If HasText = LookForText Then
If LookForText Then
LookForText = Not LookForText
Else
Done = True
TblRow.Cells(C).Range.Select
Exit For
End If
End If
Next C
If Done Then Exit For
Next R
If Done Then
Txt = "Cell #" & C & " in row " & R & " is free."
Else
Txt = "No free cell was found that" & vbCr & _
" follows one that has text."""
End If
End With
MsgBox Txt, vbInformation, "Search result"
End Sub
For ... Each is faster but I instinctively distrust it because the sequence of items in them is usually determined by the sequence of their creation. That may or may not be top to bottom, left to right. Calling cells by their coordinates may take a little longer but you retain control of the sequence.
As you may have discovered, determining an empty cell in Word is not as straightforward as it might appear. The code below looks for the first cell where the length of the text in the cell is 1 after removing any spaces, tabs and vbCr. You might extend this to also look for vbLF, manual line breaks and other characters that might be in a cell but not visible if you have view text markers turned off.
The .Cells method of a table range is the most appropriate tool to use here because it will work even if the table has merged cells. Searching a table using the cell coordinates will fail if there are merged cells in the table. Using the .Cells method the table is searched from Top Left to Bottom right (row by column).
Option Explicit
Sub Test()
Dim myCell As Word.Range
Set myCell = FirstEmptyCell(ActiveDocument.Tables(1).Range)
myCell.Select
End Sub
' Returns the first cell that has a text length of 1
' after removing spaces and tab characters from the cell text
Public Function FirstEmptyCell(ByVal TableRange As Word.Range) As Word.Range
Dim myCell As Word.Cell
For Each myCell In TableRange.Tables(1).Range.Cells
Dim CellText As String
CellText = myCell.Range.Text
CellText = Replace(CellText, vbTab, vbNullString)
CellText = Replace(CellText, " ", vbNullString)
CellText = Replace(CellText, vbCr, vbNullString)
If Len(CellText) = 1 Then
Set FirstEmptyCell = myCell.Range
Exit Function
End If
Next
End Function
The solution is really much simpler than the other 'answers' suggest:
Dim i As Long
With Selection
If .Information(wdWithInTable) = True Then
With .Tables(1).Range
For i = 1 To .Cells.Count
With .Cells(i)
If Len(.Range.Text) = 2 Then
MsgBox " Row " & .RowIndex & ", Column " & .ColumnIndex & " is empty."
.Range.PasteSpecial DataType:=wdPasteText
Exit For
End If
End With
Next
End With
Else
MsgBox "No table selected", vbExclamation
End If
End With
I've even added some error checking.
I'm having trouble making sure that my code uses what the end user inputs to find a set of data pertaining to that value and continues with the code there. For example, if the user were to input "V-" as the prefix to the tag number, in theory cell A7 should be selected after the code is complete. However, the code proceeds to run line "MsgBox "No blank cell was found below a tag number with prefix " & str & ".", vbExclamation" and select cell A3 due to the fact that it contains "V-" in the cell. I tried changing the Matchcase to true but it did not help. I also do not want the entered value to be case sensitive.
Code being used:
Private Sub Worksheet_Activate()
Dim msg As String
Dim Cell As Range
Dim str As String, firstcell As String
msg = "Would you like to find the next available tag number?"
result = MsgBox(msg, vbYesNo)
If result = vbYes Then
str = Application.InputBox("Enter The Tag Number Prefix ", "Prefix To Tag Number")
If str = "" Then Exit Sub
If Right(str, 1) <> "-" Then str = str & "-"
With Range("A:A")
Set Cell = .Find(str, lookat:=xlPart, MatchCase:=False)
If Not Cell Is Nothing Then
firstcell = Cell.Address
Do
If Cell.Offset(1, 0) = "" Then
Cell.Offset(1, 0).Select
Exit Sub
ElseIf InStr(LCase(Cell.Offset(1, 0)), LCase(str)) = 0 Then
Cell.Select
MsgBox "No blank cell was found below a tag number with prefix " & str & ".", vbExclamation
Exit Sub
End If
Set Cell = .FindNext(Cell)
Loop While Not Cell Is Nothing And firstcell <> Cell.Address
End If
End With
Else
Cancel = True
End If
End Sub
If you want to find cells whose content begins with (e.g.) "V-" then
Set Cell = .Find(str & "*", lookat:=xlWhole, MatchCase:=False)
For the data below:
Sub tester()
With ActiveSheet.Columns(1)
Debug.Print .Find("C-" & "*", lookat:=xlWhole, _
MatchCase:=False).Address() '>> $A$3
Debug.Print .Find("V-" & "*", lookat:=xlWhole, _
MatchCase:=False).Address() '>> $A$5
End With
End Sub
I'm experiencing some issues getting the provided VBA code working and would appreciate any assistance.
I have two Workbooks (1) is a monthly report I receive that has multiple worksheets, Worksheet "host_scan_data" contains the source of the information I will need to work with. The other Workbook (2) is where I will store all consolidated date month over month.
How I'm trying to accomplish this task:
1. launch workbook #2
2. click a button that has the following VBA code assigned to (see below)
3. browse and select my monthly report (workbook #1)
4. specify the worksheet tab in workbook #2 where i'd like to store this consolidate information
5. prompt user to validate worksheet tab where data will be stored
Based on the responses above the macro will then analyze Column K within the "host_scan_data" Sheet of the Workbook (1), and I would like for it to remove all rows where Column k contains a "0" (note the only values i'm concerned about are 4,3,2,1). Once that action is complete i'd like for the macro to copy the consolidated list of entry's over to the location specified in step #4 above.
I've tried this with a few variations of code and other solutions appear to work fine when the "host_scan_data" Sheet contains <4,000 rows however once I exceed that number (give or take) excel becomes unresponsive. Ideally this solution will need to handle approx 150,000+ rows.
Here is the code i'm currently using, when i execute it errors out at ".Sort .Columns(cl + 1), Header:=xlYes":
The Code I Have so far:
Sub Import()
Dim strAnswer
Dim itAnswer As String
Dim OpenFileName As String
Dim wb As Workbook
Dim db As Workbook
Dim Avals As Variant, X As Variant
Dim i As Long, LR As Long
'Optimize Code
Call OptimizeCode_Begin
'Select and Open workbook
OpenFileName = Application.GetOpenFilename("*.xlsx,")
If OpenFileName = "False" Then Exit Sub
Set wb = Workbooks.Open(OpenFileName, UpdateLinks:=0)
Set db = ThisWorkbook
'Provide Sheet Input
strAnswer = InputBox("Please enter name of worksheet where Nessus data will be imported:", "Import Name")
If strAnswer = "" Then
MsgBox "You must enter a valid name. Exiting now..."
wb.Close
Exit Sub
Else
Response = MsgBox(strAnswer, vbYesNo + vbCritical + vbDefaultButton2, "Is this Correct?")
If Response = vbNo Then
MsgBox "Got it, you made a mistake. Exiting now..."
wb.Close
Exit Sub
Else: MsgBox "Importing Now!"
End If
End If
wb.Sheets("host_scan_data").Activate
Dim rs, cl, Q()
Dim arr1, j, C, s As Long
Dim t As String: t = "4"
Dim u As String: u = "3"
Dim v As String: v = "2"
Dim w As String: w = "1"
If Cells(1) = "" Then Cells(1) = Chr(2)
'Application.Calculation = xlManual
rs = wb.Sheets("host_scan_data").Cells.Find("*", , , , , xlByRows, xlPrevious).Row
cl = wb.Sheets("host_scan_data").Cells.Find("*", , , , , xlByColumns, xlPrevious).Column
ReDim Q(1 To rs, 1 To 1)
arr1 = wb.Sheets("host_scan_data").Cells(1, "k").Resize(rs)
For j = 1 To rs
C = arr1(j, 1)
If (C <> t) * (C <> u) * (C <> v) * (C <> w) Then Q(j, 1) = 1: s = s + 1
Next j
If s > 0 Then
With Cells(1).Resize(rs, cl + 1)
.Columns(cl + 1) = Q
.Sort .Columns(cl + 1), Header:=xlYes
.Cells(cl + 1).Resize(s).EntireRow.Delete
End With
End If
countNum = (Application.CountA(Range("B:B"))) - 1
MsgBox (countNum & " Rows being imported now!")
countNum = countNum + 2
db.Sheets(strAnswer).Range("A3:A" & countNum).value = wb.Sheets("host_scan_data").Range("B3:B" & countNum).value
db.Sheets(strAnswer).Range("B3:B" & countNum).value = wb.Sheets("host_scan_data").Range("K3:K" & countNum).value
db.Sheets(strAnswer).Range("C3:C" & countNum).value = wb.Sheets("host_scan_data").Range("H3:H" & countNum).value
db.Sheets(strAnswer).Range("D3:D" & countNum).value = wb.Sheets("host_scan_data").Range("M3:M" & countNum).value
db.Sheets(strAnswer).Range("E3:E" & countNum).value = wb.Sheets("host_scan_data").Range("L3:L" & countNum).value
db.Sheets(strAnswer).Range("F3:F" & countNum).value = wb.Sheets("host_scan_data").Range("O3:O" & countNum).value
db.Sheets(strAnswer).Range("G3:G" & countNum).value = wb.Sheets("host_scan_data").Range("G3:G" & countNum).value
db.Sheets(strAnswer).Range("K3:K" & countNum).value = wb.Sheets("host_scan_data").Range("X3:X" & countNum).value
MsgBox ("Done")
'Close nessus file
wb.Close SaveChanges:=False
'Else
'MsgBox "You must enter 1 or 2 only. Exiting now..."
'wb.Close
'Exit Sub
'End If
Sheets(strAnswer).Select
'Optimize Code
Call OptimizeCode_End
End Sub
So here is what may be happening.
If the row you are deleting has data used, in a formula somewhere else, that formula is going to recalculate on every iteration of the row delete.
I had this problem with a data set which has many Vlookup functions pulling data.
here is what I did and it take a few seconds rather than 30min
Sub removeLines()
Dim i As Long
Dim celltxt As String
Dim EOF As Boolean
Dim rangesize As Long
EOF = False
i = 1
'My data has "End of File" at the end so I check for that
' Though it would be better to used usedRange
While Not (EOF)
celltxt = ActiveSheet.Cells(i, 1).Text
If InStr(1, celltxt, "end", VbCompareMethod.vbTextCompare) > 0 Then
EOF = True 'if we reach the "end Of file" then exit
' so I clear a cell that has no influence on any functions thus
' it executes quickly
ElseIf InStr(1, celltxt, "J") <> 1 Then
Cells(i, 1).Clear
End If
i = i + 1
Wend
' once all the rows to be deleted are marked with the cleared cell
' I use the specialCells to select and delete all the rows at once
' so that the dependent formula are only recalculated once
Columns("A:A").Select
Selection.SpecialCells(xlCellTypeBlanks).Select
Selection.EntireRow.Delete
End Sub
hope this helps and that it is read able
I tried a little different approach by using AutoFilter and i'm seeing a high success rate on my larger lists however there still is one issue. With the code below i was able to parse through 67k+ rows and filter/delete any row contains a "0" in my column K (this takes approx 276 seconds to complete), after the code filters and deletes the rows with zeros it clears any existing filters then is to copy the remaining data into my Workbook #2 (this is approx 7k rows) however it is consistently only copying 17 rows of data into my workbook #2, it just seems to stops and i have no idea why. Also, while 4.5 mins to complete the consolidation could be acceptable does anyone have any ideas on how to speed this up?
Sub Import()
Dim strAnswer
Dim itAnswer As String
Dim OpenFileName As String
Dim wb As Workbook
Dim db As Workbook
Dim Avals As Variant, X As Variant
Dim i As Long
Dim FileLastRow As Long
Dim t As Single
Dim SevRng As Range
t = Timer
'Optimize Code
Call OptimizeCode_Begin
'Select and Open workbook
OpenFileName = Application.GetOpenFilename("*.xlsx,")
If OpenFileName = "False" Then Exit Sub
Set wb = Workbooks.Open(OpenFileName, UpdateLinks:=0)
Set db = ThisWorkbook
'Provide Sheet Input
strAnswer = InputBox("Please enter name of worksheet where Nessus data will be imported:", "Import Name")
If strAnswer = "" Then
MsgBox "You must enter a valid name. Exiting now..."
wb.Close
Exit Sub
Else
Response = MsgBox(strAnswer, vbYesNo + vbCritical + vbDefaultButton2, "Is this Correct?")
If Response = vbNo Then
MsgBox "Got it, you made a mistake. Exiting now..."
wb.Close
Exit Sub
Else: MsgBox "Importing Now!"
End If
End If
FileLastRow = wb.Sheets("host_scan_data").Range("K" & Rows.Count).End(xlUp).Row
Set SevRng = wb.Sheets("host_scan_data").Range("K2:K" & FileLastRow)
Application.DisplayAlerts = False
With SevRng
.AutoFilter Field:=11, Criteria1:="0"
.Offset(1, 0).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Rows.Delete
.Cells.AutoFilter
End With
Application.DisplayAlerts = True
MsgBox "Consolidated in " & Timer - t & " seconds."
countNum = (Application.CountA(Range("B:B"))) - 1
MsgBox (countNum & " Rows being imported now!")
countNum = countNum + 2
db.Sheets(strAnswer).Range("A3:A" & countNum).value = wb.Sheets("host_scan_data").Range("B3:B" & countNum).value
db.Sheets(strAnswer).Range("B3:B" & countNum).value = wb.Sheets("host_scan_data").Range("K3:K" & countNum).value
db.Sheets(strAnswer).Range("C3:C" & countNum).value = wb.Sheets("host_scan_data").Range("H3:H" & countNum).value
db.Sheets(strAnswer).Range("D3:D" & countNum).value = wb.Sheets("host_scan_data").Range("M3:M" & countNum).value
db.Sheets(strAnswer).Range("E3:E" & countNum).value = wb.Sheets("host_scan_data").Range("L3:L" & countNum).value
db.Sheets(strAnswer).Range("F3:F" & countNum).value = wb.Sheets("host_scan_data").Range("O3:O" & countNum).value
db.Sheets(strAnswer).Range("G3:G" & countNum).value = wb.Sheets("host_scan_data").Range("G3:G" & countNum).value
db.Sheets(strAnswer).Range("K3:K" & countNum).value = wb.Sheets("host_scan_data").Range("X3:X" & countNum).value
MsgBox ("Done")
'Close nessus file
wb.Close SaveChanges:=False
Sheets(strAnswer).Select
'Optimize Code
Call OptimizeCode_End
End Sub
Does your
"MsgBox (countNum & " Rows being imported now!")"
return the correct number of rows?
CountA will stop counting at the first empty cell.
Try instread:
countNum = ActiveSheet.UsedRange.Rows.Count
I am new to VBA and I would really appreciate your help with the following. The code below searchers for blanks in Column A, highlights them, then it shows a message every time a cell has blanks with the cell location (e.g."No Value, in $A$1"). I copy these cells locations in another tab called "Results".
I need help with the following. I want to somehow for the message to show once with the list of cells that have blanks and their location. I do not want the message to pop out every time it finds a blank cell (I could have hundreds of blank cells in a file and clicking Ok for each one is not practical). Then that list of values will be copied in my "Results" sheet.
Here is the code I currently have:
Sub CeldasinInfo()
Dim i As Long, r As Range, coltoSearch As String
coltoSearch = "A"
For i = 1 To Range(coltoSearch & Rows.Count).End(xlUp).Row
Set r = Range(coltoSearch & i)
If Len(r.Value) = 0 Then
r.Interior.ColorIndex = 3 ' Red
r.Select
MsgBox "No Value, in " & r.Address
Sheets("Results").Range("A" & Sheets("Results").Range("A" & Rows.Count).End(xlUp).Row).Offset(1, 0).Formula = r.Address
End If
Next
End Sub
Thank so much in advance. I would really appreciate your help with this.
Something like this should work for you:
Sub CeldasinInfo()
Dim i As Long, r As Range, coltoSearch As String
Dim Result as String
Dim ErrCount as integer
ErrCount = 0
coltoSearch = "A"
coltoSearch = Range("1:1").find(What:="Hours", LookIn:=xlValues, LookAt:=xlWhole).Column
Result = "No Value in:" & vbcrlf
For i = 1 To Range(coltoSearch & Rows.Count).End(xlUp).Row
Set r = Range(coltoSearch & i)
If Len(r.Value) = 0 Then
r.Interior.ColorIndex = 3 ' Red
r.Select
' MsgBox "No Value, in " & r.Address
Result = Result & r.Address & vbcrlf
ErrCount = ErrCount + 1
if ErrCount Mod 10 = 0 then 'change to 15 or 20 or whatever works well
MsgBox Result
Result = "No Value in:" & vbcrlf
End If
Sheets("Results").Range("A" & Sheets("Results").Range("A" & Rows.Count).End(xlUp).Row).Offset(1, 0).Formula = r.Address
End If
Next
If ErrCount > 0 then
MsgBox "There were " & ErrCount & " errors detected." & vbcrlf & result
else
MsgBox "No errors detected"
End If
End Sub
This will give you each address on a separate line in the MsgBox. If there are hundreds of errors likely, this will result in a very long MsgBox output, and I'm not sure how it will handle that. You may need to add in a counter and display the message every 10, 15 or 20 errors for a better looking output.
If your cells are truly blank you can avoid a range loop and use SpecialCells
Sub CeldasinInfo()
Dim rng1 As Range
Dim coltoSearch As String
coltoSearch = "A"
On Error Resume Next
Set rng1 = Columns(coltoSearch).SpecialCells(xlCellTypeBlanks)
On Error GoTo 0
If rng1 Is Nothing Then Exit Sub
rng1.Interior.ColorIndex = 3 ' Red
MsgBox "No Value, in " & rng1.Address
End Sub
I have VBA code which converts a given specific date format into a normal Date. Is there a way in which I can replace the entire column into my new date format may be by a button click or just using a function.
The code I have is:
Function CONVDATE(myDate) As Date
Dim arr
arr = Split(myDate)
CONVDATE = arr(1) & " " & arr(2) & " " & arr(5) & " " & arr(3)
End Function
Immediately to the right of your data enter:
=TEXT(LEFT(A1,11)&RIGHT(A1,4),"ddd mm dd yyyy")
and double-click the fill handle. Then select, Copy and Paste Special Values over the top.
If you want a VBA solution, and you are happy with your CONVDATE function, you can use something like the following to convert an entire column:
===================================
Option Explicit
Sub CONVALLDATES()
Dim RNG As Range, C As Range
'Next line may change depending on how your range to convert is set up
Set RNG = Range("A1", Cells(Rows.Count, "A").End(xlUp))
'Uncomment next line when debugged.
'application.ScreenUpdating = False
For Each C In RNG
With C
.Value = CONVDATE(C)
'.numberformat = whatever format you want it displayed
End With
Next C
Application.ScreenUpdating = True
End Sub
'---------------------------------------------
Function CONVDATE(myDate) As Date
Dim arr
arr = Split(myDate)
CONVDATE = arr(1) & " " & arr(2) & " " & arr(5) & " " & arr(3)
End Function
====================================
You should add some error checking to ensure the string you are trying to convert is, indeed, in the specific format.