How do we modify program to remove unique values in cell and do not end of string? - excel

How do we modify program to remove unique values in cell and do not end of string with this value?
We need remove rows
from c3delete.txt file with unique values
first
second etc..
from excel c3 column in excel file***
Sub RemoveRowsRentruck()
Dim sh As Worksheet, N1 As Long, d1 As Long, arrCond, El, txtFileName As String
Dim objFSO As Object, objTxt As Object, rngDel As Range, strText As String
Set sh = ThisWorkbook.ActiveSheet 'use here the necessary sheet (not necessary to be activated)
sh.Cells.ClearFormats
txtFileName = ThisWorkbook.Path & "\" & "c3delete.txt" 'fill here the text file full name
Set objFSO = CreateObject("Scripting.FileSystemObject")
If Not objFSO.FileExists(txtFileName) Then 'check if the text file exists in the path
MsgBox "The text file does not exist on the path: """ & txtFileName & """."
Exit Sub
End If
Set objTxt = objFSO.OpenTextFile(txtFileName, 1)
strText = objTxt.ReadAll 'read the text file content
objTxt.Close
arrCond = Split(strText, vbCrLf) 'put it in an array splitting on vbCrLf (end of line)
N1 = Range("C" & Rows.Count).End(xlUp).Row 'last row of the G:G column
For d1 = 1 To N1 'iterate between the existing range
For Each El In arrCond 'check each element of the array keeping conditions
If El <> "" Then
If InStr(1, sh.Cells(d1, 3).Text, El, vbTextCompare) > 0 Then
If rngDel Is Nothing Then 'if the range to be deleted not Set
Set rngDel = sh.Cells(d1, 3)
Else
Set rngDel = Union(rngDel, sh.Cells(d1, 3)) 'if already Set
End If
End If
End If
Next El
Next d1
'delete all the rows at once:
If Not rngDel Is Nothing Then rngDel.EntireRow.Delete xlUp
End Sub
--------------------
c3delete.txt file with content
first
second
----------------
excel file a1 b2 c3
five
first
second
seven
first
nine

Related

VBA script invalid procedure or argument error

Sub FindAndWrite()
Dim FindValues() As String
Dim WriteValue As String
Dim FoundCell As Range
Dim LastRow As Long
Dim i As Integer
Dim j As Integer
Dim FSO As Object
Dim TS As Object
Dim ConcatenateRange As Range
Dim ExternalWorkbook As Workbook
Dim ExternalData As Variant
Set FSO = CreateObject("Scripting.FileSystemObject")
Set TS = FSO.OpenTextFile("C:\Users\2093960\Desktop\tobewritten.xlsx", 1) 'replace "C:\path\to\file.txt" with the path to your file
FindValues = Split(TS.ReadAll, vbCrLf) 'read the values from the file and store them in an array
TS.Close
WriteValue = "Completed" 'replace "value_to_write" with the value you want to write to column Z
LastRow = ActiveSheet.Cells(Rows.Count, "B").End(xlUp).Row 'get the last row of column B
Set ExternalWorkbook = Workbooks.Open("C:\Users\2093960\Desktop\tobewritten.xlsx") 'replace with the path to your external file
ExternalData = Replace(Replace(ExternalWorkbook.Sheets("Sheet1").Range("A1").Value, "-", "_"), " ", "") 'modify this line to access the cell with your data and replace hyphens with underscores and remove spaces
For i = 1 To LastRow 'loop through each row in column B
Set ConcatenateRange = Range("A" & i & ":C" & i) 'change this to the range of cells containing your data
Set FoundCell = ActiveSheet.Range("B" & i)
For j = 0 To UBound(FindValues) 'loop through each value in the array
If InStr(Replace(Join(Application.Transpose(ConcatenateRange.Value), ""), "-", "_"), Replace(FindValues(j), "-", "_")) > 0 Or InStr(Replace(ExternalData, "-", "_"), Replace(FindValues(j), "-", "_")) > 0 Then 'check if the current value from the array is in the concatenated range or external data
FoundCell.Offset(0, 25).Value = WriteValue 'write the WriteValue to column Z in the same row
Exit For 'exit the inner loop when a match is found
End If
Next j
Next i
ExternalWorkbook.Close SaveChanges:=False 'close the external workbook without saving changes
End Sub
this is my code to find a cell in column B and update status in Column Z , the data to find Iam getting it from anothet excel which has hyphens and underscore in it while trying to run this Ima getting
invalid procedure or arguments error in
If InStr(Replace(Join(Application.Transpose(ConcatenateRange.Value), ""), "-", "_"), Replace(FindValues(j), "-", "_")) > 0 Or InStr(Replace(ExternalData, "-", "_"), Replace(FindValues(j), "-", "_")) > 0 Then 'check if the current value from the array is in the concatenated range or external data
Any suggestions on this please
tried with multiple ways , changing data type but dint work
Instr takes 3 parameters, the first is the starting position to search...
If InStr(1, Replace(Join(Application.Transpose(ConcatenateRange.Value), ""), "-", "_"), Replace(FindValues(j), "-", "_"))

Add another filter criteria

How do I add another filter criteria?
So that I can filter by date (like it does) and if comboBox1 value = to what is in column A for each row
The other one I have is filter by date (like it does) and if there is a value in column H for each row
Private Sub CommandButton1_Click()
Dim strStart As String, strEnd As String, strPromptMessage As String
If TextBox1.Value = "" Then
TextBox1.Value = Date
End If
If TextBox2.Value = "" Then
TextBox2.Value = Date
End If
'Prompt the user to input the start date
strStart = TextBox1.Value
'Validate the input string
If Not IsDate(strStart) Then
strPromptMessage = "Oops! It looks like your entry is not a valid " & _
"date. Please retry with a valid date..."
MsgBox strPromptMessage
Exit Sub
End If
'Prompt the user to input the end date
strEnd = TextBox2.Value
'Validate the input string
If Not IsDate(strStart) Then
strPromptMessage = "Oops! It looks like your entry is not a valid " & _
"date. Please retry with a valid date..."
MsgBox strPromptMessage
Exit Sub
End If
'Call the next subroutine, which will do produce the output workbook
Call CreateSubsetWorksheet(strStart, strEnd)
Unload Me
End Sub
Public Sub CreateSubsetWorksheet(StartDate As String, EndDate As String)
Dim wksData As Worksheet, wksTarget As Worksheet
Dim lngLastRow As Long, lngLastCol As Long, lngDateCol As Long
Dim rngFull As Range, rngResult As Range, rngTarget As Range
'Set references up-front
Set wksData = ThisWorkbook.Worksheets("CopyDatabase")
lngDateCol = 5 '<~ we know dates are in column E
'Identify the full data range on Sheet1 (our data sheet) by finding
'the last row and last column
lngLastRow = LastOccupiedRowNum(wksData) '<~ straight from VBA Toolbelt!
'lngLastRow = Cells(Rows.Count, 1).End(xlUp).Row
lngLastCol = LastOccupiedColNum(wksData) '<~ straight from VBA Toolbelt!
'lngLastCol = Cells(1, Columns.Count).End(xlToLeft).Column
With wksData
Set rngFull = .Range(.Cells(3, 1), .Cells(lngLastRow, lngLastCol))
End With
'Apply a filter to the full range we just assigned to get rows
'that are in-between the start and end dates
With rngFull
.AutoFilter Field:=lngDateCol, _
Criteria1:=">=" & StartDate, _
Criteria2:="<=" & EndDate
'If the resulting range contains only 1 row, that means we filtered
'everything out! Check for this situation, catch it and exit
If wksData.AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Count = 1 Then
MsgBox "Oops! Those dates filter out all data!"
'Clear the autofilter safely and exit sub
wksData.AutoFilterMode = False
If wksData.FilterMode = True Then
wksData.ShowAllData
End If
Exit Sub
Else '<~ otherwise we're all good!
'Assign ONLY the visible cells, which are in the
'date range specified
Set rngResult = .SpecialCells(xlCellTypeVisible)
'clear contents
ThisWorkbook.Sheets("Reports").Range("A3:A" & Range("A3").End(xlDown).Row).ClearContents
ThisWorkbook.Sheets("Reports").Range("B3:B" & Range("B3").End(xlDown).Row).ClearContents
ThisWorkbook.Sheets("Reports").Range("C3:C" & Range("C3").End(xlDown).Row).ClearContents
ThisWorkbook.Sheets("Reports").Range("D3:D" & Range("D3").End(xlDown).Row).ClearContents
ThisWorkbook.Sheets("Reports").Range("E3:E" & Range("E3").End(xlDown).Row).ClearContents
ThisWorkbook.Sheets("Reports").Range("F3:F" & Range("F3").End(xlDown).Row).ClearContents
ThisWorkbook.Sheets("Reports").Range("G3:G" & Range("G3").End(xlDown).Row).ClearContents
ThisWorkbook.Sheets("Reports").Range("H3:H" & Range("H3").End(xlDown).Row).ClearContents
ThisWorkbook.Sheets("Reports").Range("I3:I" & Range("I3").End(xlDown).Row).ClearContents
ThisWorkbook.Sheets("Reports").Range("J3:J" & Range("J3").End(xlDown).Row).ClearContents
ThisWorkbook.Sheets("Reports").Range("K3:K" & Range("K3").End(xlDown).Row).ClearContents
ThisWorkbook.Sheets("Reports").Range("L3:L" & Range("L3").End(xlDown).Row).ClearContents
ThisWorkbook.Sheets("Reports").Range("M3:M" & Range("M3").End(xlDown).Row).ClearContents
ThisWorkbook.Sheets("Reports").Range("N3:N" & Range("N3").End(xlDown).Row).ClearContents
ThisWorkbook.Sheets("Reports").Range("O3:O" & Range("O3").End(xlDown).Row).ClearContents
ThisWorkbook.Sheets("Reports").Range("P3:P" & Range("P3").End(xlDown).Row).ClearContents
ThisWorkbook.Sheets("Reports").Range("Q3:Q" & Range("Q3").End(xlDown).Row).ClearContents
'Create a new Worksheet to copy our data to and set up
'a target Range (for super easy copy / paste)
Set wksTarget = ThisWorkbook.Sheets("Reports")
Set rngTarget = wksTarget.Cells(2, 1)
rngResult.Copy Destination:=rngTarget
End If
End With
'Clear the autofilter safely
wksData.AutoFilterMode = False
If wksData.FilterMode = True Then
wksData.ShowAllData
End If
'Holler at the user, our macro is done!
MsgBox "Data transferred!"
End Sub

Excel VBA: Search Folder and Sub-Folders for Part Numbers Listed in Excel

Beginner in VBA so sorry if the code is bad.
What I wanted to achieve was to search a folder and its sub folders for the .dxf file of a part number listed in Column B, and return either a "Yes" or "No" depending on whether that .dxf file exist in that folder or its sub folders.
What I expected was that the code would begin with the first part number listed in B2, search the folder and sub folders for the .dxf file related, return a value, then move on to the next one, B3 then B4 and so on until the part numbers stop.
What it does is search a folder for all listed part numbers in Column B, returns all values, then searches a subfolder, returns all values (overriding the previous results) and so on until there are no more subfolders to search.
I feel like I'm close to getting the result I want but not sure where I've gone wrong.
Code is below:
Option Explicit
Dim FileSystem As Object
Dim HostFolder As String
Sub FindFile()
HostFolder = "C:\Users\Anyone\DXF\"
Set FileSystem = CreateObject("Scripting.FileSystemObject")
DoFolder FileSystem.GetFolder(HostFolder)
End Sub
Sub DoFolder(Folder)
Dim SubFolder
Dim Row As Integer
Dim Extension As String
Dim Continue As Boolean
For Each SubFolder In Folder.SubFolders
DoFolder SubFolder
Next
Dim File
For Each File In Folder.Files
Continue = True
Extension = ".DXF"
Row = 2
While Continue
If Len(Range("B" & CStr(Row)).Value) = 0 Then Exit Sub
If Len(Dir(Folder.Path & "\" & Range("B" & CStr(Row)).Value & "*" & Extension)) = 0 Then
Range("F" & CStr(Row)).Value = "No"
Else
Range("F" & CStr(Row)).Value = "Yes"
End If
Row = Row + 1
Wend
Next
End Sub
I would rethink the approach here. Maybe try a macro to manage the row loop and a function to manage the file lookup
First macro to loop through all file names in Column B and outputs if a file is found in Column C
Second macro to search a folder/subfolder path. If the file is found, the loop ends and returns TRUE. If a file is not found, the macro runs it's course and exists with FALSE
Note the function is just demonstrating the logic. You just need to take the logic you have to manage the folder loop and implement in this function
Sub File_Range()
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Sheet1")
Dim lr As Long, i As Long
lr = ws.Range("B" & ws.Rows.Count).End(xlUp).Row
For i = 2 To lr
If Not IsEmpty(ws.Range("B" & i)) Then
ws.Range("C" & i) = File_Exists(Range("B" & i))
End If
Next i
End Sub
Public Function File_Exists(Target As Range) As Boolean
'False until file is found
File_Exists = False
For Each SubFolder In Folder.SubFolders
If Len(Dir(Folder.Path & "\" & Target.Value & "*" & Extension)) Then
File_Exists = True
Exit Function
End If
Next SubFolder
End Function
Check Files for Existence
The Basics
Basically (inaccurately), the following writes all file paths of the required (DXF) files found in the supplied folder path to an array, replaces them with file names without file extension and checks the values (file names) in the source column against the array and finally writes the required results (Yes/No) to the destination column.
Adjust the values in the constants section.
Only run checkFiles, the rest is being called by it.
Additional Functionality
To better understand the flow, in the Immediate window CTRL+G, you can monitor what is happening, if you uncomment the Debug.Print sections. Note that Join will fail if error values, but you can always create a loop like it is done for mData which possibly (probably) contains error values.
It will allow different worksheets for source and destination data.
If will allow source and destination data starting in different rows.
The Code
Option Explicit
Sub checkFiles()
Const FolderPath As String = "C:\Users\Anyone\DXF"
Const FileExt As String = "DXF" ' Not case-sensitive i.e. 'DXF = dxf'
Const fFound As String = "Yes"
Const fNotFound As String = "No"
Const srcName As String = "Sheet1"
Const srcFirst As String = "B2"
Const dstName As String = "Sheet1"
Const dstFirst As String = "F2"
Dim wb As Workbook
Set wb = ThisWorkbook
Dim rng As Range ' (Source and Destination) Data Range
Dim Data As Variant ' (Source and Destination) Data Array
Dim fData() As String ' File Data Array
Dim mData As Variant ' Match Data Array
Dim n As Long ' File Data and (Match) Data Array Elements Counter
' Write values from Source Range to Data Array.
Set rng = defineColumnRange(defineRange(wb.Worksheets(srcName), srcFirst))
Data = getColumn(rng)
'Debug.Print "Source Data:" & vbLf & Join(Application.Transpose(Data), vbLf)
' Write file paths to File Data Array.
fData = getFilePaths(FolderPath, "*." & FileExt)
'Debug.Print "File Data - File Paths:" & vbLf & Join(fData, vbLf)
' Replace file paths with file names without file extension.
For n = LBound(fData) To UBound(fData)
fData(n) = FileFromPath(fData(n), True) ' 'True' means no extension.
Next n
'Debug.Print "File Data - File Names:" & vbLf & Join(fData, vbLf)
' Write 'matches' to Match Data Array.
mData = Application.Match(Data, fData, 0)
'Debug.Print "Match Data:"
'For n = 1 To UBound(mData)
' Debug.Print mData(n, 1)
'Next
' Overwrite values in Data Array with 'matching results'.
For n = 1 To UBound(Data) ' or 'UBound(mData)'
If IsNumeric(mData(n, 1)) Then
Data(n, 1) = fFound
Else
Data(n, 1) = fNotFound
End If
Next n
'Debug.Print "Destination Data:" & vbLf _
& Join(Application.Transpose(Data), vbLf)
' Write values from Data Array to Destination Range.
With defineRange(wb.Worksheets(dstName), dstFirst)
Dim RowOffset As Long: RowOffset = .Row - rng.Row
Dim ColumnOffset As Long: ColumnOffset = .Column - rng.Column
Set rng = .Worksheet.Range(rng.Offset(RowOffset, ColumnOffset).Address)
End With
rng.Value = Data
End Sub
Function defineRange( _
ws As Worksheet, _
ByVal RangeAddress As String) _
As Range
On Error Resume Next
Set defineRange = ws.Range(RangeAddress)
On Error GoTo 0
End Function
Function defineColumnRange( _
FirstCell As Range) _
As Range
If Not FirstCell Is Nothing Then
With FirstCell
Dim rng As Range
Set rng = .Resize(.Worksheet.Rows.Count - .Row + 1)
Set rng = rng.Find("*", , xlFormulas, , , xlPrevious)
If Not rng Is Nothing Then
Set defineColumnRange = .Resize(rng.Row - .Row + 1)
End If
End With
End If
End Function
Function getColumn( _
rng As Range) _
As Variant
If Not rng Is Nothing Then
If InStr(rng.Address, ":") > 0 Then
getColumn = rng.Value
Else
Dim Data As Variant
ReDim Data(1 To 1, 1 To 1)
Data(1, 1) = rng.Value
getColumn = Data
End If
End If
End Function
Function getFilePaths( _
ByVal FolderPath As String, _
Optional ByVal FilePattern As String = "") _
As Variant
Dim ExecString As String
ExecString = "cmd /c Dir """ & FolderPath & Application.PathSeparator _
& FilePattern & """ /b/s"
getFilePaths = Filter(Split(CreateObject("WScript.Shell") _
.Exec(ExecString).StdOut.ReadAll, vbCrLf), ".") ' 'vbCrLf' is a must.
End Function
Function FileFromPath( _
ByVal FilePath As String, _
Optional ByVal NoExtension As Boolean = False) _
As String
Dim FileName As String
FileName = Right(FilePath, _
Len(FilePath) - InStrRev(FilePath, "\"))
If NoExtension Then
FileName = Left(FileName, InStrRev(FileName, ".") - 1)
End If
FileFromPath = FileName
End Function

how do we rewrite this program that it collects data from input.txt file with content

How do we rewrite this program in order for it to collect data from input.txt file or second excel sheet with content:
test
mark
class ...
and delete rows in exel file with this text.
Sub RemoveRowsAv()
ThisWorkbook.ActiveSheet.Cells.ClearFormats
Dim n As Long, d As Long
n = Range("G" & Rows.Count).End(xlUp).Row
For d = n To 1 Step -1
If InStr(1, ThisWorkbook.ActiveSheet.Cells(d, 7).Text, "test", vbTextCompare) > 0 Then
ThisWorkbook.ActiveSheet.Cells(d, 7).EntireRow.Delete
End If
If InStr(1, ThisWorkbook.ActiveSheet.Cells(d, 7).Text, "mark", vbTextCompare) > 0 Then
ThisWorkbook.ActiveSheet.Cells(d, 7).EntireRow.Delete
End If
Next d
End Sub
file input.txt
test
mark
class
You read the file and put every word of that file in a collection.
Then, instead of:
If InStr(..., "test", ...) Then
....EntireRow.Delete
End If
You do something like:
For Each entry in Collection
If Instr(..., entry, ...) Then
....EntireRow.Delete
End If
Next
Test the next code, please. It needs a text file named "input.txt". In my example code it is located in the folder where ThisWorkbook has the path:
Sub RemoveRowsAv()
Dim sh As Worksheet, n As Long, d As Long, arrCond, El, txtFileName As String
Dim objFSO As Object, objTxt As Object, rngDel As range, strText As String
Set sh = ThisWorkbook.ActiveSheet 'use here the necessary sheet (not necessary to be activated)
sh.cells.ClearFormats
txtFileName = ThisWorkbook.Path & "\" & "input.txt" 'fill here the text file full name
Set objFSO = CreateObject("Scripting.FileSystemObject")
If Not objFSO.FileExists(txtFileName) Then 'check if the text file exists in the path
MsgBox "The text file does not exist on the path: """ & txtFileName & """."
Exit Sub
End If
Set objTxt = objFSO.OpenTextFile(txtFileName, 1)
strText = objTxt.ReadAll 'read the text file content
objTxt.Close
arrCond = Split(strText, vbCrLf) 'put it in an array splitting on vbCrLf (end of line)
n = range("G" & rows.count).End(xlUp).row 'last row of the G:G column
For d = 1 To n 'iterate between the existing range
For Each El In arrCond 'check each element of the array keeping conditions
If El <> "" Then
If InStr(1, sh.cells(d, 7).text, El, vbTextCompare) > 0 Then
If rngDel Is Nothing Then 'if the range to be deleted not Set
Set rngDel = sh.cells(d, 7)
Else
Set rngDel = Union(rngDel, sh.cells(d, 7)) 'if already Set
End If
End If
End If
Next El
Next d
'delete all the rows at once:
If Not rngDel Is Nothing Then rngDel.EntireRow.Delete xlUp
End Sub

How do I, modify vba code to repeat until finished?

I found a piece of vba code that counts the number of xml files in a specific folder, i modified it to only count files with a specific string (located in cell F3) as part of the file name. And print that count in the adjacent cell (cell G3). Its working as expected.
My problem is that I need the results for a entire range. The range of strings are created from a pivot table.
I tried just dublicating the code and modifying the reference cells, and that works. But the range can be from a few strings to 70+, i'm sure that there is a much more efficient and cleaner way than running the code 70+ times.
Dim FolderPath As String, path As String, count As Integer
FolderPath = "C:\Test\PJC"
path = FolderPath & "\*" & Range("F3") & "*.xml"
FileName = Dir(path)
Do While FileName <> ""
count = count + 1
FileName = Dir()
Loop
Range("G3").Value = count
There you have alternatives:
' One line solution, but can count all files only, without wildcards
Debug.Print CreateObject("Scripting.FileSystemObject").GetFolder("C:\temp\").Files.count
' Counting all *.pdf files in C:\temp
FolderPath = "\\temp\\"
Path = "pdf"
Dim objWMIService As Object
Dim objFiles As Object
Set objWMIService = GetObject("winmgmts:\\.\root\cimv2")
Set objFiles = objWMIService.ExecQuery("Select * from CIM_DataFile where Path = '" & FolderPath & "' and Extension = '" & Path & "'")
Debug.Print "Files count: ", objFiles.Count
Iterating over a Range can be achieved as follows:
Sub IterateRange()
Dim rng As Range, cell As Range
Dim myWs As Worksheet
Set myWs = Application.Worksheets("sheet1")
Set rng = myWs.Range("A1:A6")
For Each cell In rng
MsgBox cell.Value
Next cell
End Sub
Often iterating might be more straightforward using the .Cells property of a Worksheet, it could look like this:
Sub IterateRange()
Dim i As Long
Dim myWs As Worksheet
Set myWs = Application.Worksheets("Sheet1")
for i=1 to 6
MsgBox myWs.Cells(i, 1)
next i
End Sub
For your example, if you have the strings you want to check for in the Range F3:F73, and the count results should be in the Range G3:G73 the loop you are looking for might look something like this:
Sub Example()
Dim FolderPath As String, path As String, count As Integer, i As Integer
Dim myWs As Worksheet
Set myWs = Application.Worksheets("Sheet1")
For i = 3 To 73
count=0
FolderPath = "C:\Test\PJC"
path = FolderPath & "\*" & myWs.Cells(i, 6) & "*.xml"
Filename = Dir(path)
Do While Filename <> ""
count = count + 1
Filename = Dir()
Loop
myWs.Cells(i, 7) = count
Next i
End Sub
For the loop to stop automatically after the last row of input strings just add
if myWs.Cells(i, 6)="" then
exit for
end if
between the lines For i = 3 To 73 and count=0
Guess this will do the trick.
I took your code and put it in a For loop.
I define the start row as row 3.
EndRange will search for the last value in column F. The For loop will iterate from StartRange to EndRange values.
I also made the count to print the the result from the count variable for each loop in the G column.
Sub LoopRange()
Dim FolderPath As String, path As String, count As Integer
Dim StartRange As Long, EndRange As Long
StartRange = 3 'Row = 3 for start
EndRange = Cells(Rows.count, "F").End(xlUp).Row 'Find last row in column F
For i = StartRange To EndRange 'Loop from start to end value
FolderPath = "C:\Test\PJC"
path = FolderPath & "\*" & Range(Cells(i, "F"), Cells(i, "F")) & "*.xml" 'Take the value from row i and column F in the loop.
Filename = Dir(path)
Do While Filename <> ""
count = count + 1
Filename = Dir()
Loop
Range(Cells(i, "G"), Cells(i, "G")).Value = count 'Print the count
Next i
End Sub

Resources