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), "-", "_"))
Related
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
I have a worksheet with many columns (82 in my case) and I am looking to create a csv-file for each column. I manage to do it with the below code, thanks to the help of many questions/answers on this site. Running the code gives some action on the windows taskbar I have not seen before (the creation and closing of the files) but I have the feeling there is a more efficient and faster way. Any suggestions?
' Create a separate csv file for each column.
Sub ColumnsToCSV()
Dim i As Byte
Dim cols As Byte ' column count
Dim name As String ' 01, 02, .., 99
cols = ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Column ' count columns
For i = 1 To cols ' loop columns
name = Format(i, "00") ' 1 => 01, etc.
Sheets.Add(After:=Sheets(Sheets.Count)).name = name ' add sheet
Sheets("Data").Columns(i).Copy Destination:=Sheets(name).Columns(1) ' copy data
ThisWorkbook.Sheets(name).Copy ' create copy
ActiveWorkbook.SaveAs Filename:=name, FileFormat:=xlCSV ' save to csv
ActiveWorkbook.Close ' close csv
Application.DisplayAlerts = False ' disable alerts
ActiveSheet.Delete ' delete sheet
Application.DisplayAlerts = True ' enable alerts
Next i
End Sub
Try this out:
' Create a separate csv file for each column.
Sub ColumnsToCSV()
Dim name As String, pth As String, cols As Long, i As Long
Dim rng As Range, data, ws As Worksheet, r As Long, v
Set ws = ActiveSheet
cols = ws.UsedRange.SpecialCells(xlCellTypeLastCell).Column
pth = ThisWorkbook.Path & "\" 'or whereever you want to save....
For i = 1 To cols
data = AsArray(ws.Range(ws.Cells(1, i), ws.Cells(Rows.Count, i).End(xlUp)))
For r = 1 To UBound(data, 1)
v = data(r, 1)
If InStr(v, ",") > 0 Then data(r, 1) = """" & v & """" 'quote commas
Next r
'write the output (note Tanspose() has a limit of approx 63k items)
PutContent pth & Format(i, "00") & ".csv", _
Join(Application.Transpose(data), vbCrLf)
Next i
End Sub
'write text to a file
Sub PutContent(f As String, content As String)
CreateObject("scripting.filesystemobject"). _
opentextfile(f, 2, True).write content
End Sub
'return range value as array (handle case where range is a single cell)
Function AsArray(rng As Range)
Dim rv()
If rng.Cells.Count = 1 Then
ReDim rv(1 To 1, 1 To 1)
rv(1, 1) = rng.Value
AsArray = rv 'edit: this was missing...
Else
AsArray = rng.Value
End If
End Function
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
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
I am trying to create a Tree Traversal in Excel for a schedule I have. I am at the point where I have 2 lists each 1006 cells long. The first is predecessors, the second is successors. I am trying to use a set of functions to display multiple results. For instance if I enter 3, I want all of the successors of task 3 to get listed. So far the code I have come up with is:
=IF(ISERROR(INDEX($A$1:$B$1006,SMALL(IF($A$1:$A$1006=$E$3,ROW($A$1:$A$1006)),ROW(1:1)),2)),"NO",INDEX($A$1:$B$1006,SMALL(IF($A$1:$A$1006=$E$3,ROW($A$1:$A$1006)),ROW(1:1)),2))
However when I input the predecessor, it does not display the correct successor.
Thank you in advance for whoever can help me
You cannot join values with formulas (or at least, i can't see an easy way to do it).
You can either call a procedure (faster but more intrusive):
Option Explicit
Sub Proc_ListPre()
Dim rData As Range, lLastrow As Long, i As Integer
Dim aValues() As Variant
Dim sFilter As String, sRes As String
'Ask for the value to filter to the user
sFilter = InputBox("Which predecessor do you want to analyse?", "Please type the predecessor you want")
If Len(sFilter) = 0 Then Exit Sub
'Define the range
'either use UsedRange (if only columns A and B are used)
'Set rData = ActiveSheet.UsedRange
'or use End(xlUp) if not
lLastrow = ActiveSheet.Range("a65536").End(xlUp).Row
Set rData = ActiveSheet.Range("A1:B" & lLastrow)
'Filter the predecessor with the criteria given in arg
rData.AutoFilter Field:=1, Criteria1:=sFilter
'Find the last row of the filtered data
lLastrow = ActiveSheet.Range("a65536").End(xlUp).Row
aValues = ActiveSheet.Range("A2:B" & lLastrow).Value
'Join the 2nd column of the array
'Join(WorksheetFunction.Index(aValues, 0, 2), ";") 'note that this doesn't work because index returns a 2D array
'Workaround to join the 2nd column
For i = 1 To UBound(aValues, 1)
If Len(CStr(aValues(i, 2))) > 0 Then
sRes = sRes & aValues(i, 2) & ";"
End If
Next
sRes = Left(sRes, Len(sRes) - 1)
MsgBox sRes
ActiveSheet.AutoFilterMode = False
End Sub
or use a formula that you will call in your worksheet as =ListPre(mypredecessor)
Function ListPre(ByVal sFilter As String)
Dim rData As Range, lLastrow As Long, i As Integer
Dim aValues() As Variant
Dim sRes As String
'Define the range
'either use UsedRange (if only columns A and B are used)
'Set rData = ActiveSheet.UsedRange
'or use End(xlUp) if not
lLastrow = ActiveSheet.Range("a65536").End(xlUp).Row
Set rData = ActiveSheet.Range("A1:B" & lLastrow)
aValues = ActiveSheet.Range("A2:B" & lLastrow).Value
'Join the 2nd column of the array
'Join(WorksheetFunction.Index(aValues, 0, 2), ";") 'note that this doesn't work because it returns a 2D array
'Workaround to join the 2nd column
For i = 1 To UBound(aValues, 1)
If Len(CStr(aValues(i, 2))) > 0 And CStr(aValues(i, 1)) = sFilter Then
sRes = sRes & aValues(i, 2) & ";"
End If
Next
sRes = Left(sRes, Len(sRes) - 1)
ListPre = sRes
End Function