Get specific values from an range and store it in another - vba

I'm trying to type a search term and look into a entire specific range and every time this term has a match the information will be stored in another column.
When I use "Do", "With" or "While" it just stores one result.
Sub MethodFindAllSamples()
Dim rng1 As Range
Dim strSearch As String
index = 11
strSearch = InputBox("Type the model you are looking for, please: ")
Set rng1 = Range("G:G").Find(strSearch, , xlValues, xlPart, xlByRows, False)
If Not rng1 Is Nothing Then
Application.Goto rng1
Model = ActiveCell(1.1)
Content = ActiveCell(1, 4)
FIssues = Range("ER" & ActiveCell.Row + 1).Value
TIssues = Range("ER" & ActiveCell.Row + 1).Value
MsgBox "Model selected: " & Model & vbNewLine & "CS: " & Content & vbNewLine & " Issues found: " & FIssues
Errors = Left(FIssues, 1)
Errors2 = Mid(TIssues, 22, 1)
Cells(index, 1).Value = Mid(Model, 4, 6)
Cells(index, 3).Value = Errors
Cells(index, 4).Value = Errors2
Cells(index, 2).Value = strSearch + Left(Content, 8)
Else
MsgBox strSearch & " This device can't be found, please try again"
End If
End Sub

this an example how you can achieve this
Sub MethodFindAllSamples()
Dim oCell As Range, i&, z&, strSearch$
strSearch = InputBox("Type the model you are looking for, please: ")
i = Cells(Rows.Count, "G").End(xlUp).Row
z = 0
If strSearch <> "" Then
For Each oCell In Range("G1:G" & i)
If Replace(Trim(UCase(oCell.Value)), " ", "") Like "*" & Replace(Trim(UCase(strSearch)), " ", "") & "*" Then
z = z + 1
End If
Next
If z > 0 Then
MsgBox "Range [D] contain: " & z & " iteration of the selected model : " & strSearch
Else
MsgBox "Range [D] does not contain: " & strSearch
End If
Else
MsgBox "Search model not specified!"
End If
End Sub

Related

Inserting a Formula into Cell with table reference using VBA

I'm trying to insert a formula into a cell so a variable that is captured with a MsgBox function is inserted into the formula.
TmpPT = "=IF(NOT(ISBLANK(INDEX(" & "Table10[Recvd Date]" & ",MATCH("" * """ & prjNum & """ * "" ," & "Table10[Project Name]" & ",0)))),INDEX(" & "Table10[Recvd Date]" & ",MATCH("" * """ & prjNum & """ * ""," & "Table10[Project Name]" & ",0))," & "Not Yet Received" & ")"
The overall objective for my code below is to unhide another sheet and insert data into a range within that sheet. If irrelevant, please disregard the information.
Private Sub CommandButton1_Click()
Dim SetPT As Variant
Dim TmpStg As Variant
Dim r As Integer
Dim c As Integer
Dim prjNum As Variant
Dim titlerng As Range
Dim outptrng As Range
r = 0
c = 0
SetPT = "A1"
Sheets("MG Rpt").Visible = True
Sheets("MG Rpt").Activate
ActiveSheet.Range(SetPT).Select
r = 8
ActiveCell.Offset(r, c).Activate
ActiveCell.Value = "Project #:"
ActiveCell.Offset(1, c).Activate
ActiveCell.Value = "Received Date:"
ActiveCell.Offset(1, c).Activate
ActiveCell.Value = "Elapsed Time:"
ActiveCell.Offset(1, c).Activate
ActiveCell.Value = "Expected Completion:"
ActiveCell.Offset(1, c).Activate
ActiveCell.Value = "Feedback:"
prjNum = InputBox("Please enter the Project # you are requesting down below.", "Project Search Query")
ActiveCell.Offset(-4, 1).Value = prjNum
ActiveCell.Offset(-4, 0).Activate
TmpStg = "=IF(NOT(ISBLANK(INDEX(" & "Table10[Recvd Date]" & ",MATCH("" * """ & prjNum & """ * "" ," & "Table10[Project Name]" & ",0)))),INDEX(" & "Table10[Recvd Date]" & ",MATCH("" * """ & prjNum & """ * ""," & "Table10[Project Name]" & ",0))," & "Not Yet Received" & ")"
Range("B10").Formula = TmpPT
End Sub
Am I missing an object or am I failing to format a line? Learning VBA as I go :)
The formula should look like this:
=IF(NOT(ISBLANK(INDEX(Table10[Recvd Date],MATCH("*"&prjNum&"*",Table10[Project Name],0)))),INDEX(Table10[Recvd Date],MATCH("*"&prjNum&"*",Table10[Project Name],0)),"Not Yet Received")
Solution:
Got it! Here's the final output that got it to work:
TmpStg = "=IF(NOT(ISBLANK(INDEX(Table10[Recvd Date],MATCH(""*""&" & prjNum & "&""*"",Table10[Project Name],0)))),INDEX(Table10[Recvd Date],MATCH(""*""&" & prjNum & "&""*"",Table10[Project Name],0)),""Not Yet Received"")"
Thanks for the help everyone!
Try Avoiding Select and Activate while minimizing the string concatenation down to what is absolutely necessary.
Option Explicit
Private Sub CommandButton1_Click()
Dim tmpStg As Variant, prjNum As Variant
prjNum = InputBox("Please enter the Project # you are requesting down below.", "Project Search Query")
tmpStg = "=IF(LEN(INDEX(Table10[Recvd Date], MATCH(""*" & prjNum & "*"", Table10[Project Name], 0))), " & _
"INDEX(Table10[Recvd Date], MATCH(""*" & prjNum & "*"", Table10[Project Name], 0)), ""Not Yet Received"")"
Debug.Print tmpStg
With Worksheets("MG Rpt")
.Visible = True
.Cells(9, "A").Resize(5, 1) = _
Application.Transpose(Array("Project #:", "Received Date:", "Elapsed Time:", _
"Expected Completion:", "Feedback:"))
.Cells(9, "B") = prjNum
.Cells(10, "B").Formula = tmpStg
.Cells(10, "B").NumberFormat = "mm/dd/yyyy"
.Activate
End With
End Sub
Do you really need to bracket wildcard the project number?

VBA - Creating Word Document from Excel and Edit Certain Line to Contain Bold Text

I am looking to bold every second line entry on a word document that receives input from an excel spreadsheet. In other words, I want the resulting word document to have each line containing 'ID:' to contain bold text. I've looked into other examples but I keep getting errors such as mismatch.
Sub ExceltoWord_TestEnvironment()
Dim wApp As Object
Dim wDoc As Object
Dim strSearchTerm
Dim FirstMatch As Range
Dim FirstAddress
Dim intMyVal As String
Dim lngLastRow As Long
Dim strRowNoList As String
Dim intPlaceHolder As Integer
Set wApp = CreateObject("Word.Application")
Set wDoc = CreateObject("Word.Document")
wApp.Visible = True
Set wDoc = wApp.Documents.Add
wDoc.Range.ParagraphFormat.SpaceBefore = 0
wDoc.Range.ParagraphFormat.SpaceAfter = 0
strSearchTerm = InputBox("Please enter the date to find", "Search criteria")
If strSearchTerm <> "" Then
Set FirstMatch = ActiveSheet.Cells.Find(strSearchTerm, LookAt:=xlPart, MatchCase:=False)
If FirstMatch Is Nothing Then
MsgBox "That date could not be found"
Else
FirstAddress = FirstMatch.Address
intMyVal = strSearchTerm
lngLastRow = Cells(Rows.Count, "F").End(xlUp).Row 'Search Column F, change as required.
For Each cell In Range("F1:F" & lngLastRow) 'F is column
If InStr(1, cell.Value, intMyVal) Then
If strRowNoList = "" Then
strRowNoList = strRowNoList & cell.Row
intPlaceHolder = cell.Row
wDoc.Content.InsertAfter "Group: " & Cells(intPlaceHolder, 3) & vbNewLine
wDoc.Content.InsertAfter "ID: " & Cells(intPlaceHolder, 2) & vbNewLine
wDoc.Content.InsertAfter "Name: " & vbNewLine & vbNewLine
Else
strRowNoList = strRowNoList & ", " & cell.Row
intPlaceHolder = cell.Row
wDoc.Content.InsertAfter "Group: " & Cells(intPlaceHolder, 3) & vbNewLine
wDoc.Content.InsertAfter "ID: " & Cells(intPlaceHolder, 2) & vbNewLine
wDoc.Content.InsertAfter "Name: " & vbNewLine & vbNewLine
End If
Next cell
MsgBox strRowNoList
While Not FirstMatch Is Nothing
Set FirstMatch = ActiveSheet.Cells.FindNext(FirstMatch)
If FirstMatch.Address = FirstAddress Then
Set FirstMatch = Nothing
End If
Wend
End If
End If
End Sub
Example:
Group: Group A
ID: 123456
Name: Jon Snow
Group: Group B
ID: 789101
Name: Samwell Tarly
I was able to find a work around. Thought I would post it here to help others. Sorry my code isn't as clean as I would like it to be. Copying and pasting didn't quite match up.
Sub ExceltoWord_TestEnvironment()
Dim wApp As Object
Dim wDoc As Object
Dim strSearchTerm
Dim FirstMatch As Range
Dim FirstAddress
Dim intMyVal As String
Dim lngLastRow As Long
Dim strRowNoList As String
Dim intPlaceHolder As Integer
Set wApp = CreateObject("Word.Application")
Set wDoc = CreateObject("Word.Document")
wApp.Visible = True
Set wDoc = wApp.Documents.Add
wDoc.Range.ParagraphFormat.SpaceBefore = 0
wDoc.Range.ParagraphFormat.SpaceAfter = 0
strSearchTerm = InputBox("Please enter the date to find", "Search criteria")
If strSearchTerm <> "" Then
Set FirstMatch = ActiveSheet.Cells.Find(strSearchTerm, LookAt:=xlPart, MatchCase:=False)
If FirstMatch Is Nothing Then
MsgBox "That date could not be found"
Else
FirstAddress = FirstMatch.Address
intMyVal = strSearchTerm
lngLastRow = Cells(Rows.Count, "F").End(xlUp).Row 'Search Column F, change as required.
For Each cell In Range("F1:F" & lngLastRow) 'F is column
If InStr(1, cell.Value, intMyVal) Then
If strRowNoList = "" Then
strRowNoList = strRowNoList & cell.Row
intPlaceHolder = cell.Row
intParaCount = wDoc.Paragraphs.Count
i = 2
Set objParagraph = wDoc.Paragraphs(i).Range
With objParagraph
.Font.Bold = True
End With
wDoc.Content.InsertAfter "Group: " & Cells(intPlaceHolder, 3) & vbNewLine
wDoc.Content.InsertAfter "ID: " & Cells(intPlaceHolder, 2) & vbNewLine
wDoc.Content.InsertAfter "Name: " & vbNewLine & vbNewLine
i = i + 4 'paragraph number
Else
strRowNoList = strRowNoList & ", " & cell.Row
intPlaceHolder = cell.Row
wDoc.Content.InsertAfter "Group: " & Cells(intPlaceHolder, 3) & vbNewLine
wDoc.Content.InsertAfter "ID: " & Cells(intPlaceHolder, 2) & vbNewLine
wDoc.Content.InsertAfter "Name: " & vbNewLine & vbNewLine
i = i + 4
End If
Next cell
MsgBox strRowNoList
While Not FirstMatch Is Nothing
Set FirstMatch = ActiveSheet.Cells.FindNext(FirstMatch)
If FirstMatch.Address = FirstAddress Then
Set FirstMatch = Nothing
End If
Wend
End If
End If
End Sub
The code utilizes .paragraphs() where 'i' is the paragraph you want to bold:
i = 2
Set objParagraph = wDoc.Paragraphs(i).Range
With objParagraph
.Font.Bold = True
End With
And the difference in paragraphs is added after each iteration
i = i + 4 'paragraph number

Excel Application Crash due to Macro

During launching my macro the Excel application is crashed. If I test the macro with an integer the program runs properly (partnumber = 123). If I check with a string the application is crashed. Thus, no error code is visible for me. I assume that there is a type mismatch (but I set Variant for partnumber)
Sub SbIsInCOPexport()
Dim lastRow As Long
Dim i As Long
Dim found As Boolean
Dim partnumber As Variant
i = 1
found = False
partnumber = ActiveCell.Value
Windows("COPexport.xlsx").Activate
lastRow = Sheets(1).Cells.SpecialCells(xlLastCell).Row
Do While i < lastRow + 1
If Cells(i, 6).Value = partnumber Then
found = True
Exit Do
End If
i = i + 1
Loop
If found = True Then
Cells(i, 6).Select
MsgBox ("Searched part number: " & Str(partnumber) & vbNewLine & "Found part number: " _
& ActiveCell.Value & vbNewLine & "Address: " & Cells(i, 6).Address & vbNewLine & vbNewLine & "Test Order: " & _
Cells(i, 2).Value)
Windows("COPexport.xlsx").Activate
Else
MsgBox "Part number is not found in the COP samples!"
Windows("COPexport.xlsx").Activate
End If
End Sub
What can be the root cause?
I don't see any obvious issues, but consider using the .Find method of range object, like so:
Sub SbIsInCOPexport()
Dim partnumber as Variant
Dim rng as Range
Windows("COPexport.xlsx").Activate
partnumber = ActiveCell.Value
Set rng = Columns(6).Find(partnumber) '## Search in column 6 for partnumber
If rng Is Nothing Then
MsgBox "Part number is not found in the COP samples!"
Windows("COPexport.xlsx").Activate
Else
With rng
MsgBox ("Searched part number: " & Str(partnumber) & vbNewLine & _
"Found part number: " & .Value & vbNewLine & _
"Address: " & .Address & vbNewLine & vbNewLine & _
"Test Order: " & .Offset(0,-4).Value) '## Get the value from column 2
End With
End If
End Sub

Excel VBA: how to apply code when it finds text in a column

I have the following code, modified by #FreeMan from one of my previous questions. I want to find the text "Hours" in any row in the worksheet. Then, apply the code to the column containing that text. This code is supposed to do that, but it does not work for me for some reason. I would really appreciate your help with this. Thank you in advance.
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
You need to change these two lines of code:
For i = 1 To Range(coltoSearch & Rows.Count).End(xlUp).Row
Set r = Range(coltoSearch & i)
to:
For i = 1 To Cells(Rows.Count, coltoSearch).End(xlUp).Row
Set r = Cells(i, coltoSearch)
Remove line: coltoSearch = "A"
coltoSearch should be an integer.

Copy data to new workbook and add specific text to each row´s value in a specific column

I am exporting data from one workbook to another workbook to T13:Tlastrow
This data, from column F in my workbook where I run this macro, I want to be put into {nyckel="TEXT HERE";} in column T in the "new" workbook, starting from row 13 (T13).
I am stuck here. So would really appreciate some help/solution. Thanks!
Sub CopyData()
Dim wkbCurrent As Workbook, wkbNew As Workbook
Set wkbCurrent = ActiveWorkbook
Dim valg, c, LastCell As Range
Set valg = Selection
Dim wkbPath, wkbFileName, lastrow As String
Dim LastRowInput As Long
Dim lrow, rwCount, lastrow2, LastRowInput2 As Long
Application.ScreenUpdating = False
' If nothing is selected in column A
If Selection.Columns(1).Column = 1 Then
wkbPath = ActiveWorkbook.Path & "\"
wkbFileName = Dir(wkbPath & "CIF LISTEN.xlsm")
Set wkbNew = Workbooks.Open(wkbPath & "CIF LISTEN.xlsm")
'Application.Run ("'C:\Users\niclas.madsen\Desktop\TEST\CIF LISTEN.xlsm'!DelLastRowData")
LastRowInput = Cells(Rows.count, "A").End(xlDown).Row
For Each c In valg.Cells
lrow = wkbNew.Worksheets(1).Range("B1").Offset(wkbNew.Worksheets(1).Rows.count - 1, 0).End(xlUp).Row + 1
lastrow2 = Range("A" & Rows.count).End(xlUp).Row
lastrow3 = Range("T" & Rows.count).End(xlUp).Row
wkbCurrent.ActiveSheet.Range("E" & c.Row).Copy Destination:=wkbNew.Worksheets(1).Range("A" & lrow)
wkbCurrent.ActiveSheet.Range("A" & c.Row).Copy Destination:=wkbNew.Worksheets(1).Range("B" & lrow)
wkbCurrent.ActiveSheet.Range("F" & c.Row).Copy Destination:=wkbNew.Worksheets(1).Range("T" & lrow)
' Standard inputs
wkbNew.Worksheets(1).Range("D13:D" & lastrow2).Value = "Ange referens och period"
wkbNew.Worksheets(1).Range("E13:E" & lastrow2).Value = "99999002"
wkbNew.Worksheets(1).Range("G13:G" & lastrow2).Value = "EA"
wkbNew.Worksheets(1).Range("H13:H" & lastrow2).Value = "2"
wkbNew.Worksheets(1).Range("M13:M" & lastrow2).Value = "SEK"
wkbNew.Worksheets(1).Range("N13:N" & lastrow2).Value = "sv_SE"
wkbNew.Worksheets(1).Range("P13:P" & lastrow2).Value = "TRUE"
wkbNew.Worksheets(1).Range("Q13:Q" & lastrow2).Value = "TRUE"
wkbNew.Worksheets(1).Range("S13:S" & lastrow2).Value = "Catalog_extensions"
'wkbNew.Worksheets(1).Range("T" & lastrow3).Value = "{Nyckelord=" & wkbNew.Worksheets(1).Range("T" & lastrow3).Value & ";}"
Next
' Trying to get this to work
LastRowInput2 = wkbNew.Worksheets(1).Range("T" & wkbNew.Sheets("Sheet1").UsedRange.Rows.count + 1).End(xlUp).Row
For i = 0 To LastRowInput2 - 13
wkbNew.Worksheets(1).Range("T" & 13 + i).Value = "{Nyckelord=" & wkbNew.Worksheets(1).Range("T" & 13 + i).Value & ";}"
Next i
' END HERE
' wkbNew.Close False
' Find the number of rows that is copied over
wkbCurrent.ActiveSheet.Activate
areaCount = Selection.Areas.count
If areaCount <= 1 Then
MsgBox "The selection contains " & Selection.Rows.count & " suppliers."
' Write it in A10 in CIF LISTEN
wkbNew.Worksheets(1).Range("A10").Value = "COMMENTS: " & Selection.Rows.count & " Suppliers Added"
Else
i = 1
For Each A In Selection.Areas
'MsgBox "Area " & I & " of the selection contains " & _
a.Rows.count & " rows."
i = i + 1
rwCount = rwCount + A.Rows.count
Next A
MsgBox "The selection contains " & rwCount & " suppliers."
' Write it in A10 in CIF LISTEN
wkbNew.Worksheets(1).Range("A10").Value = "COMMENTS: " & rwCount & " Suppliers Added"
End If
wkbNew.Worksheets(1).Activate
Application.ScreenUpdating = True
Else
MsgBox "Please select cell(s) in column A", vbCritical, "Error"
Exit Sub
End If
End Sub
OK Try
wkbNew.Worksheets(1).Range("T" & lrow).Value = "{Nyckelord=" & wkbCurrent.ActiveSheet.Range("F" & c.Row).Value & "}"
Instead of your line:
wkbCurrent.ActiveSheet.Range("F" & c.Row).Copy Destination:=wkbNew.Worksheets(1).Range("T" & lrow)
And remove the whole block marked 'Trying to get this to work
If the code is doing the right action but on the wrong cells, then the problem is in the start and end of the For loop. Your For Loop is going from row '13 + i' where i = 0 (so row 13), to row 13 + LastRowInput2 - 13 (so LastRowInput2). This seems right to me, so the problem must be with the value in LastRowInput2.
You need to correct this line:
LastRowInput2 = wkbNew.Worksheets(1).Range("T" & wkbNew.Sheets("Sheet1").UsedRange.Rows.count + 1).End(xlUp).Row
So that is gives you the correct last row input in your data. There are several approaches to finding the end of data depending on whether there may be blank cells in the middle and other factors. This may be one option:
LastRowInput2 = wkbNew.Worksheets(1).Range("T65000").End(xlUp).Row
Be sure to step through the code and verify that LastRowInput2 is set to the value you expect and then this should work.