So I asked this question last week and I kind of have a solution to this question, but there is just one piece that is not working. The Application.Match part does not seem to work. I am also getting results when myarray does not match with arr(1).
The original question was :
What I am trying to do with this code is to :
Go through all the files in that specified folder and all the subfolders in that folder. (The files in that folder are usually separated in 5 parts by underscore. For example, "XX1_XX2_XX3_XX4_XX5"
If any of the 3 character indicators in my myarray matches XX2 from the filename, then list XX4 on Cell(22,3) and XX5 on Cell(22,4) and keep repeating ......Cell(23,3),Cell(23,4),Cell(24,3,),Cell(24,4).....etc. I want only exact matches.. not sure how to do that.
There are some files in the folder that has only 3 underscores... so "XX1_XX2_XX3_XX4". For these files, if myarray matches XX2, then list XX4 on Cells(i,3) and show "NO INDICATOR" for Cells(i,4)
Sub tracker()
Const FPATH As String = "\\KEVINXX\FILESXX\FILES\"
Dim f As String, i, j As Long, arr, sht As Worksheet
Dim myarray As Variant
myarray = Array("XXX", "AAA", "BBB", "SBM", "SBS", "JDS", "QQQ", "WWW", "CCC", "DDD", "EEE", "XXX", "AAS", "RRR", "SSS", "KKK", "ABX")
Set sht = ActiveSheet
f = Dir("\\KEVINXX\FILESXX\FILES\")
i = 22
Do While f <> ""
'split filename on underscore
arr = Split(f, "_", 5)
If UBound(arr) >= 3 Then
If IsError(Application.Match(arr(1), myarray, 0)) Then
If UBound(arr) = 3 Then
sht.Cells(i, 3).Value = Left(arr(3), Len(arr(3)) - 5)
sht.Cells(i, 4).Value = "No Indicator"
Else
sht.Cells(i, 3).Value = arr(3)
If UBound(arr) >= 4 Then
sht.Cells(i, 4).Value = Left(arr(4), Len(arr(4)) - 5)
End If
End If
i = i + 1
End If 'no match
End If
f = Dir() 'next file
Loop
End Sub
Have you tried looping through the array
for x = 0 to 16
If IsError(Application.Match(arr(1), myarray(x), 0)) Then
If UBound(arr) = 3 Then
sht.Cells(i, 3).Value = Left(arr(3), Len(arr(3)) - 5)
sht.Cells(i, 4).Value = "No Indicator"
Else
sht.Cells(i, 3).Value = arr(3)
If UBound(arr) >= 4 Then
sht.Cells(i, 4).Value = Left(arr(4), Len(arr(4)) - 5)
End If
End If
i = i + 1
End If 'no match
next x
Be kind and rewind or leave feedback)
Related
The below VBA code sets a range of cells as commentArray, removes any blanks from the array and creates a new, blank free array, called commentResults. I then want to declare the array.
There is a possibility, depending on my source data, that the array could then still be empty so the below doesn't work to declare
thisws.Cells(i, 19).Resize(columnsize:=UBound(commentResults) - LBound(commentResults) + 1).Value = commentResults
So I thought I would add a check (the if statement after the debug.print), that only declared the array if array(0) wasn't empty but I continuously get an error 9 which I can't resolve.
Dim commentArray(4) As Variant
commentArray(0) = Cells(24, 4).Value
commentArray(1) = Cells(25, 3).Value
commentArray(2) = Cells(26, 3).Value
commentArray(3) = Cells(27, 3).Value
'a and b as array loops
Dim a As Long, b As Long
Dim commentResults() As Variant
'loops through the array to remove blanks - rewrites array without blanks into commentArray
For a = LBound(commentArray) To UBound(commentArray)
If commentArray(a) <> vbNullString Then
ReDim Preserve commentResults(b)
commentResults(b) = commentArray(a)
b = b + 1
End If
Next a
Debug.Print b
If IsError(Application.Match("*", (commentResults), 0)) Then
Else
thisws.Cells(i, 19).Resize(columnsize:=UBound(commentResults) - LBound(commentResults) + 1).Value = commentResults
b = 0
End If
Any thoughts on why this might not work?
I have also tried:
If commentResults(0) <> vbNullString Then
thisws.Cells(i, 27).Resize(columnsize:=UBound(commentResults) - LBound(commentResults) + 1).Value = commentResults
End If
Sub CommentArray()
Dim Comments As Range, c As Range
Set Comments = Union(Cells(24, 4), Range(Cells(25, 3), Cells(27, 3)))
Dim commentResults() As Variant
Dim i As Long
i = 0
For Each cell In Comments
If cell.Value <> "" Then
ReDim Preserve commentResults(i)
commentResults(i) = cell.Value
i = i + 1
End If
Next cell
Dim debugStr As String
For i = LBound(commentResults) To UBound(commentResults)
debugStr = debugStr & commentResults(i) & Chr(10)
Next i
MsgBox debugStr
End Sub
So I've been playing around with Excel VBA to see what I can do with it. Currently, I'm stuck on one problem. My code is this:
Sub Validate_Input_Click()
Dim temp As String
For Row = 7 To 250
If Application.WorksheetFunction.CountBlank(Range(Cells(Row, 2), Cells(Row, 12))) = 0 Then
temp = ""
For col = 2 To 12
If Cells(Row, col) <> "" Then
If temp <> "" Then temp = temp & "_"
temp = temp & Cells(Row, col)
End If
Next col
Cells(Row, 1) = temp
End If
Next Row
End Sub
This works exactly as I want it to. What I'm trying to do now is, lets say in a few cells of columns B through E have Text with a dash then more text, for example:
Test - Testing
What I want to do along with concatenating is, Grab everything to the left of that dash in each individual cell. So it would look something like,
Running_This_Test_In_Some_Kind_Of_Format
instead of:
Running_This_Test - Testing_In_Some_Kind_Of_Format
I've tried creating an integer and creating a Left statement but keeps giving me not enough memory errors or using wrong argument, not sure what I'm doing incorrectly. So any help would be much appreciated!
You can replace
temp = temp & Cells(Row, col)
with
pos = InStr(1, Cells(Row, col), "-", vbTextCompare) 'find the position of dash
If pos Then 'if dash position exists
temp = temp & Trim(Left(Cells(Row, col), pos - 1)) 'take left part of that string and trim to get rid of spaces
Else
temp = temp & Cells(Row, col) 'else do it as you did it before
End If
There is no need to check for empty cell again as you are already checking them with CountBlank.
What about this?
Sub Validate_Input_Click()
Dim temp As String, str As String
Dim iRow As Long, Col As Long
For iRow = 7 To 250
If Application.WorksheetFunction.CountBlank(Range(Cells(iRow, 2), Cells(iRow, 12))) = 0 Then
temp = ""
For Col = 2 To 12
str = Trim(Split(Cells(iRow, Col), "-")(0))
If temp = "" Then
temp = str
Else
temp = temp & "_" & str
End If
Next Col
Cells(iRow, 1) = temp
End If
Next iRow
End Sub
Some slight alterations made... probably not the cleanest solution, but a solution nonetheless:
Sub Validate_Input_Click()
Dim temp As String, nextstring As String
Dim i As Long
For Row = 7 To 250
If Application.WorksheetFunction.CountBlank(Range(Cells(Row, 2), Cells(Row, 12))) = 0 Then
temp = ""
For col = 2 To 12
If Cells(Row, col) <> "" Then
If InStr(Cells(Row, col), "-") > 0 Then
For i = 1 To Len(Cells(Row, col))
If Mid(Cells(Row, col), i, 1) = "-" Then
nextstring = Left(Cells(Row, col), i - 2)
Exit For
End If
Next i
Else
nextstring = Cells(Row, col)
End If
If temp <> "" Then temp = temp & "_"
temp = temp & nextstring
End If
Next col
Cells(Row, 1) = temp
End If
Next Row
End Sub
In messing around with the code I think I found another solution to my own problem. The code looks like:
Sub Validate_Input_Click()
Dim temp As String
Dim s As String
For Row = 7 To 250
If Application.WorksheetFunction.CountBlank(Range(Cells(Row, 2), Cells(Row, 12))) = 0 Then
temp = ""
For col = 2 To 12
If Cells(Row, col) <> "" Then
s = temp
If temp <> "" Then temp = Split(s, " - ")(0) & "_"
temp = temp & Cells(Row, col)
End If
Next col
Cells(Row, 1) = temp
End If
Next Row
End Sub
Would this be a viable solution as well? Or would something else work better like the answer above from #dwirony?
Or the following. It will be fast as uses array, typed functions, used range and compared with vbNullString.
Option Explicit
Public Sub Concat()
Application.ScreenUpdating = False
Dim arr(), wb As Workbook, ws As Worksheet, i As Long, j As Long, concatString As String
Set wb = ThisWorkbook
Set ws = wb.Worksheets("Sheet9") 'Change as required
With ws
arr = Intersect(.Range("B:E"), .UsedRange)
For i = LBound(arr, 1) To UBound(arr, 1)
concatString = vbNullString
For j = LBound(arr, 2) To UBound(arr, 2)
If InStr(1, arr(i, j), "-") > 0 Then concatString = concatString & Left$(arr(i, j), InStr(1, arr(i, j), "-") - 1)
Next j
.Cells(i, 1) = Join$(Split(Trim$(concatString), Chr$(32)), "_")
Next i
End With
Application.ScreenUpdating = True
End Sub
Data:
I have a small range of cells, C6:C10. I'm trying to apply an if statement to this range of cells using VBA code. Currently, my code takes the output of the if statement for the first cell (C6), and replicates that value for cells C7:C10. The if statement is correct, I'm just not sure how to apply it to a range of cells in a column.
Sub Cleanup()
Dim Segment As String
Dim i As Integer
Segment = ActiveCell(6, 3).Value
For i = 6 To 10
If Right(Left(Segment, 6), 1) = "/" Then
ActiveCell(i, 3).Value = Left(Segment, 5)
Else
ActiveCell(i, 3).Value = Left(Segment, 6)
End If
Next i
End Sub
It should be fine if you use Cells instead of ActiveCell, except that you'll have to change your loop to go from 7 to 10 or else it will over-write the original cell as well as C7:C10.
Sub Cleanup()
Dim Segment As String
Dim i As Integer
Segment = Cells(6, 3).Value
For i = 7 To 10
If Right(Left(Segment, 6), 1) = "/" Then
Cells(i, 3).Value = Left(Segment, 5)
Else
Cells(i, 3).Value = Left(Segment, 6)
End If
Next i
End Sub
Sub Cleanup()
Dim Segment As String
Dim i As Integer
Segment = Cells(i, 3).Value
For i = 7 To 10
If Right(Left(Segment, 6), 1) = "/" Then
cells(i, 3).Value = Left(Segment, 5)
Else
Cells(i, 3).Value = Left(Segment, 6)
End If
Next i
End Sub
here three (out of many other) possible codes, in simplicity order (the last being more simple than the first):
Option Explicit
Sub Cleanup()
Dim Segment As String
Dim i As Integer
For i = 6 To 10
Segment = Cells(i, 3).Value '<== Cells(i, 3) is the current cell as per the current row (i)
If Mid(Segment, 6, 1) = "/" Then
Cells(i, 3).Value = Left(Segment, 5)
Else
Cells(i, 3).Value = Left(Segment, 6)
End If
Next i
End Sub
Sub Cleanup2()
Dim i As Integer
For i = 6 To 10
With Cells(i, 3) 'avoid repetitions (and a variable, too) by using 'With' keyword and implying 'Cells(i, 3)' preceeds every dot (".") till next 'End With" statement
If Right(Left(.Value, 6), 1) = "/" Then
.Value = Left(.Value, 5)
Else
.Value = Left(.Value, 6)
End If
End With
Next i
End Sub
Sub Cleanup3()
Dim i As Integer
For i = 6 To 10
With Cells(i, 3)
.Value = Left(.Value, IIf(Mid(.Value, 6, 1) = "/", 5, 6)) ' use Iif function to avoid multiple lines. Also use 'Mid' function in lieu of 'Right(Left(..))'
End With
Next i
End Sub
I want to refer a column by its header name.
Currently column is 4th one and header name is "Preference".
And the column consists of "Yes" or "No"
5th column header is "Reason"
And it is filled only when "Preference" column is "No"
My code is
Private Sub CommandButton1_Click()
Dim i As Integer
Dim MyWorksheetLastRow As Byte
Dim MyWorksheetLastColumn As Byte
MyWorksheetLastRow = Worksheets(1).Cells(Rows.Count, "A").End(xlUp).Row
MyWorksheetLastColumn = Worksheets(1).Cells(1, Columns.Count).End(xlToLeft).Column
Worksheets(1).Cells(1, MyWorksheetLastColumn + 1).Value = "Result"
For i = 2 To MyWorksheetLastRow
If Cells(i, 4).Value = "Yes" Then
Cells(i, MyWorksheetLastColumn + 1).Value = Cells(i, 4).Value
Else: Cells(i, MyWorksheetLastColumn + 1).Value = Cells(i, 5).Value
End If
Next i
End Sub
What I want is instead of Cells(i,4) , I want to call the it by column header example: Cells(i,"Preference").
Because I won't the column number of "Preference" in prior. And I use excel vba because I have to deal 20-30 similar files.
Further to my comments, if you want to do it direct, you would have to do this:
cells(i,Application.WorksheetFunction.Match("Preference", Range("1:1"), 0)).
Here is a function to find the column for X instance. I have put a subroutine in there to call it as an example for you.
Sub ColInstanceExample()
Dim MyColInstance As Long
MyColInstance = ColInstance("Preference", 2) 'Pass in what you are searching for and the instance you want to return the column number for
If MyColInstance = 0 Then
MsgBox "Not Found"
Else
MsgBox "Found at column: " & MyColInstance
End If
End Sub
Function ColInstance(HeadingString As String, InstanceNum As Long)
Dim ColNum As Long
On Error Resume Next
ColNum = 0
For X = 1 To InstanceNum
ColNum = (Range("A1").Offset(0, ColNum).column) + Application.WorksheetFunction.Match(HeadingString, Range("A1").Offset(0, ColNum + 1).Resize(1, Columns.Count - (ColNum + 1)), 0)
Next
ColInstance = ColNum
End Function
I have date in the following example format:
ABC 001
ABC 002
ABC 003
ABC 004
I want to remove duplcate rows in column A BUT leave the line with the highest value in column B (in this case 004). A simple duplicate removal doesn't give me the control on which value is not deleted (unless I'm missing something).
This is part of a larger VBA code and therefore, I'd like to do it via VBA. I greatly appreciate any and all help.
Assuming that column B contains numeric values, then you can use the code below to remove all non-max-duplicates. This works however the data is sorted since it loads the information into an array that keeps track of which value from column B is the largest.
Sub RemoveDuplicates()
Dim sht As Worksheet
Dim NonDupArr() As Variant
Dim i As Integer
Dim j As Integer
Dim EntryFound As Boolean
Set sht = ActiveSheet
'Reads range into an array and retains the records with the largest value
For i = 2 To sht.Cells(sht.Rows.Count, 1).End(xlUp).Row Step 1
EntryFound = False
'If first entry
If i = 2 Then
ReDim Preserve NonDupArr(1 To 2, 1 To 1)
NonDupArr(1, 1) = sht.Cells(i, 1).Value
NonDupArr(2, 1) = sht.Cells(i, 2).Value
'For all other entries
Else
'Loops through array to see if entry already exist
For j = LBound(NonDupArr, 2) To UBound(NonDupArr, 2)
If sht.Cells(i, 1).Value = NonDupArr(1, j) Then
'If enty exists it replaces the value from column B if larger than
'the entry allready in the array
If sht.Cells(i, 2).Value > NonDupArr(2, j) Then
NonDupArr(2, j) = sht.Cells(i, 2).Value
End If
EntryFound = True
Exit For
End If
Next j
'If no entry were found it will be added to the array
If Not EntryFound Then
ReDim Preserve NonDupArr(1 To 2, 1 To UBound(NonDupArr, 2) + 1)
NonDupArr(1, UBound(NonDupArr, 2)) = sht.Cells(i, 1).Value
NonDupArr(2, UBound(NonDupArr, 2)) = sht.Cells(i, 2).Value
End If
End If
Next i
'Loops through the sheet and removes all rows that doesn't match rows in the array
For i = sht.Cells(sht.Rows.Count, 1).End(xlUp).Row To 2 Step -1
'Searches for match in array
For j = LBound(NonDupArr, 2) To UBound(NonDupArr, 2)
'If this is not the largest entry then the row is removed
If sht.Cells(i, 1).Value = NonDupArr(1, j) And sht.Cells(i, 2).Value <> NonDupArr(2, j) Then
sht.Cells(i, 1).EntireRow.Delete
Exit For
End If
Next j
Next i
End Sub