In Excel file1, I have very big table, with numbers in each row in same column (let's say col F).
In Excel file2, I have numbers also in one column (let's say col A).
Q: How I can select all rows in file2 that contain numbers from file1 col A.
I found how to select rows in file2 that contain one string from file1... but array of strings is a little bit tricky for me and the array in file1 is very big.
Sub SelectManyRows()
Dim CatchPhrase As String
Dim WholeRange As String
Dim AnyCell As Object
Dim RowsToSelect As String
CatchPhrase = "10044" // <- here should be array from file1 col A
'first undo any current highlighting
Selection.SpecialCells(xlCellTypeLastCell).Select
WholeRange = "A1:" & ActiveCell.Address
Range(WholeRange).Select
On Error Resume Next ' ignore errors
For Each AnyCell In Selection
If InStr(UCase$(AnyCell.Text), UCase$(CatchPhrase)) Then
If RowsToSelect <> "" Then
RowsToSelect = RowsToSelect & "," ' add group separator
End If
RowsToSelect = RowsToSelect & Trim$(Str$(AnyCell.Row)) & ":" & Trim$(Str$(AnyCell.Row))
End If
Next
On Error GoTo 0 ' clear error 'trap'
Range(RowsToSelect).Select
End Sub
The following idea is trying to avoid looping which is usually inefficient. Instead, I used AdvancedFilter assuming its possible with the set of data you have.
The code works fine for the following set of data located in different sheets (File1 and File2). You would need to change it to work with workbooks as you need.
Sub qTest()
Sheets("File1").Activate
Dim sRNG As Range
Dim aRNG As Range
Set sRNG = Sheets("File2").Range("S1", Sheets("File2").Range("S1").End(xlDown))
Set aRNG = Sheets("File1").Range("A1", Sheets("File1").Range("a1").End(xlDown))
aRNG.AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=sRNG, Unique:=False
Dim aADD As String
aADD = aRNG.SpecialCells(xlCellTypeVisible).Address
aRNG.Parent.ShowAllData
Range(aADD).Select
End Sub
Something akin to this could be used. Select is avoided, except to actually select the rows you're looking for. Also this dynamically adds the same numbers to a range to be selected at the end.
Dim cl As Variant
Dim first_range As Boolean: first_range = True
Dim colF_range As Range, selected_range As Range
'colF_range is the list in File 2
Set colF_range = Workbooks("File2").Worksheets("Your_Worksheet") _
.Range("F:F")
'Go through each cell in the File 2 list
For Each cl In colF_range
'Look if that cell's value matches something
'in File 1 column A
If Not Workbooks("File1").Worksheets("Your_Worksheet") _
.Range("A:A").Find(cl.Value) Is Nothing Then
'If so, select that row in File 2
If first_range Then
Set selected_range = cl.EntireRow
first_range = False
Else
Set selected_range = Application.Union _
(cl.EntireRow, selected_range)
End If
End If
Next
Related
I'm new to vba so I need some help making my macro more efficient. It does return the desired outcome however I know there must be a much quicker way to do so I just do not have the vba experience to know how.
I have a column which contains names of people assigned to a project. Some are only one name, and others may be multiple, for example:
At the moment, my code goes through this column, separates the names by comma, and enters them individually into a new range like so:
I then use a collection for the unique names and enter them in the final desired list. The names must show up three times, blank row, next three rows are the next name, so on.It should look like this in the end:
Currently my code is the following
Sub FindUniques()
Dim Ws As Worksheet, Ns As Worksheet
Dim SubString() As String, m As Integer, k As Long, NameCount As Integer
Dim allNames As New Collection, tempRng As Range
Set Ns = Worksheets("Sheet2")
Set Ws = Worksheets("Sheet1")
'Loops through the Assigned To column, separates and finds unique names
On Error Resume Next
For i = 1 To Ws.Range("A:A").End(xlDown).Row - Range("Assigned_to").Row
SubString = Split(Range("Assigned_to").Offset(i), ", ")
For j = 0 To UBound(SubString)
allNames.Add (allNames.count), SubString(j)
Next j
Next i
On Error GoTo 0
NameCount = allNames.count
For k = 1 To NameCount
For m = 1 To 4
Ns.Cells((k - 1) * 4 + m + 7, 2) = allNames.Key(k)
Next
Range("Names").Offset((k - 1) * 4).ClearContents
Next
End Sub
It works, however there must be some way that is more efficient than entering the names into a new range and then deleting the range. How can I use a collection or an array or something of the sort to make it quicker? Any ideas would be really appreciated
edit: I have now updated the code and it is using an collection, taking values from the substring. This enters the item (0, 1, 2, ...) in the cells instead of the keys (keys here are the names). How do I get it to return the key instead of the item number?
The slowest part of VBA are worksheet interactions so we should attempt to minimize that as much as possible.
Sub FindUniques()
Dim ws As Worksheet, ns As Worksheet
Dim splitStr() As String, nameStr As Variant
Dim dict As New Dictionary
Dim lastRow As Long, i As Long
Set ns = Worksheets("Sheet2")
Set ws = Worksheets("Sheet1")
lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
'Loops through the Assigned To column, separates and finds unique names
For i = 2 To lastRow
splitStr = Split(CStr(ws.Cells(i, 1).Value), ", ")
For Each nameStr In splitStr
If Not dict.Exists(nameStr) Then dict.Add nameStr , 0
Next
Next i
i = 2
For Each nameStr In dict.Keys
ns.Cells(i, 1).Resize(3).Value = nameStr
i = i + 4
Next
End Sub
Edited With #Toddleson & #BigBen 's suggestions
Good Luck!
I have a column full of data in a format I don't like, and need them in another format. Currently they are formatted like this: "190826_095630_3E_1 (ROI 0)" and I need just the "3E" portion. I have written a string split that uses the "_" and I figure I can then just take the column of data that is produced that I want, however I can only get this to work one cell at a time while I click each one. I tried to write a for loop but I am running into trouble, most likely because I used "active.cell". Does anyone have a better way to loop this split through my column? Alternatively if you also know how to just return the third string split (3E) I would really appreciate it.
'No loop: This works for one cell
Option Explicit
Sub NameTest()
Dim txt As String
Dim i As Integer
Dim FullName As Variant
txt = ActiveCell.Value
FullName = Split(txt, "_")
For i = 0 To UBound(FullName)
Cells(1, i + 1).Value = FullName(i)
Next i
End Sub
'Attempt at a loop:
Option Explicit
Sub NameTest()
Dim txt As String
Dim i As Integer
Dim FullName As Variant
Dim x As Integer
For x = 1 To 1000
txt = ActiveCell.Value
FullName = Split(txt, "_")
For i = 0 To UBound(FullName)
Cells(1, i + 1).Value = FullName(i)
Next i
Next x
End Sub
I would like to get this to run until the last cell with data in a given column.
please bear with me as I'm very new to VBA, with prior experience primarily from Rhinoscript and other dedicated scripting options. The question is really very simple and I reckon someone can answer this very quickly, as I'm poor with arrays in VBA:
I have a spreadsheet where the objective is to import a number of values and text strings (resulting in some blanks) into e.g. A:L. This is done manually. I need to read these values into an array and then print them into a file so that each file row corresponds to a row of columns in the array. Currently I cannot seem to be able to convert the variant array into a string array (apparently necessary) and then join the subarrays into temporary arrays which are printed into the file. The following bit I've managed to scrape together results in a file output where each array value is on a single row, where as I'd like the contents of e.g. A1:L1 to be printed on single row.
Sub writerangetofile()
'Write data to a text file
'Declaring variables
Dim valarray() As Variant
Dim R As Long
Dim C As Long
'Set array as range
Sheet1.Activate
valarray() = Range("A1:L40")
'Setting the name and the path of text file based on workbook path
sFName = ThisWorkbook.Path & "\Output.txt"
'Get an unused file number
intFNumber = FreeFile
'Create a new file (or overwrite an existing one)
Open sFName For Output As #intFNumber
For R = 1 To UBound(valarray, 1) ' First array dimension is rows.
For C = 1 To UBound(valarray, 2) ' Second array dimension is columns.
Print #intFNumber, valarray(R, C)
Next C
Next R
'Close the text file
Close #intFNumber
End Sub
For simplicity as I've also not figured out how to obtain the last row with any content in it I've restricted the range to row 40 for now.
Any ideas on how to accomplish what I want elegantly? I've solved it by assigning single cells to variables, but I'd prefer to do it with an array. Ultimately I will later be interjecting a fixed text string after a recurring text string in the imported text, which is then followed by a numerical value obtained from a calculation.
Many thanks for any help and apologies for the ignorance.
In case you have any issues, this versions shows how to determine the last row and column
Option Explicit
Public Sub RangeToFile()
Dim ws As Worksheet, lr As Long, lc As Long, r As Long, c As Long
Dim arr As Variant, fName As String, fNumber As Long, txtLine As String
fName = ThisWorkbook.Path & "\Output.txt" 'File name & path based on workbook path
Set ws = Sheet1 'set a reference to main sheet
lr = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row 'find last row in column A
lc = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column 'find last column in row 1
arr = ws.Range(ws.Cells(1, "A"), ws.Cells(lr, lc)) 'Copy range to array
fNumber = FreeFile 'get next available file number assigned by windows
Open fName For Output As #fNumber 'create a new file, or overwrite an existing one
For r = 1 To UBound(arr, 1) '1st array dimension is rows
For c = 1 To UBound(arr, 2) '2nd array dimension is columns
txtLine = txtLine & arr(r, c) & ", " 'concatenate each cell in row, on a line
Next c 'the end of the row, moving to next one
txtLine = Left(txtLine, Len(txtLine) - 2) 'remove the extra comma at end of line
txtLine = txtLine & vbCrLf 'append a carriage return to the line
Next r
txtLine = Left(txtLine, Len(txtLine) - 2) 'remove carriage return at end of line
Print #fNumber, txtLine 'print entire text to the file with an extra carriage return
Close #fNumber 'close the text file
End Sub
and this one transposes columns to rows:
Public Sub RangeToFileColumnsToRows()
Dim ws As Worksheet, lr As Long, lc As Long, r As Long, c As Long
Dim arr As Variant, fName As String, fNumber As Long, txtLine As String
fName = ThisWorkbook.Path & "\Output.txt" 'File name & path based on workbook path
Set ws = Sheet1 'set a reference to main sheet
lr = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row 'find last row in column A
lc = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column 'find last column in row 1
arr = ws.Range(ws.Cells(1, "A"), ws.Cells(lr, lc)) 'Copy range to array
fNumber = FreeFile 'get next available file number assigned by windows
Open fName For Output As #fNumber 'create a new file, or overwrite an existing one
For c = 1 To UBound(arr, 2) '2nd array dimension is columns
For r = 1 To UBound(arr, 1) '1st array dimension is rows
txtLine = txtLine & arr(r, c) & ", " 'concatenate each cell in col, on a line
Next r 'the end of the col, moving to next one
txtLine = Left(txtLine, Len(txtLine) - 2) 'remove the extra comma at end of line
txtLine = txtLine & vbCrLf 'append a carriage return to the line
Next c
txtLine = Left(txtLine, Len(txtLine) - 2) 'remove carriage return at end of line
Print #fNumber, txtLine 'print entire text to the file
Close #fNumber 'close the text file
End Sub
Nevermind, I think I got a step forward:
For R = 1 To UBound(valarray, 1) ' First array dimension is rows.
For C = 1 To UBound(valarray, 2) ' Second array dimension is columns.
ReDim Preserve tvalarray(1 To C) 'Reset the array dimension on each iteration of loop whilst keeping results
'Input each single value into subarray for joining
tvalarray(C) = valarray(R, C)
'Join the subarray
jstring = Join(tvalarray)
Next C
ReDim Preserve jvalarray(1 To R) 'Reset the array dimension on each iteration of loop whilst keeping results
'Input the joined result into the new array
jvalarray(R) = jstring
'Print to file
Print #intFNumber, jvalarray(R)
Next R
This seems to do the job, I'll see if I run into pitfalls later.
For my project I am trying to extract the data from a Listbox.
The data in the listbox is like "1 x bolt", I am trying to get the "bolt" part from this sentence. Then check in which row this word is from my Excel sheet (named "Bom"). If found then find the same row but instead of column F go to column G and insert that text in my different Listbox2.
So far it tells me that strsearch doesn't work with an array.
My Code
With ONDS1
Dim PartID As String
Dim rSearch As Range 'range to search
Dim c As Range
Dim i As Long
With Sheets("Bom")
Set rSearch = .Range("f1", .Range("F1000").End(xlUp))
End With
For i = 0 To Me.ListBox_stuklijst.ListCount - 1
strfind = Split(Me.ListBox_stuklijst(i), , 3)
strfind(2) = rSearch
Set c = rSearch.Find(strfind, LookIn:=xlValues, lookat:=xlWhole)
If Not c Is Nothing Then
MsgBox "working"
End If
Next i
End With
I have been wrestling with this for a day or so and am stumped.
Here is what I want to do:
I have a sheet with a complete list of the tab names in column A. Call this Total Tabs.
I have another sheet called "Reps No Longer Here". This is the target sheet where the contents of the individual tabs in the list are to be copied to.
I can put the names into an array (2D) and access the individual members, but I need to be able to compare the list name in the array to the tab names to find the correct tab. Once found, copy ALL the contents of that tab to "Reps No Longer Here" (next available row).
When it is finished the sheet "Reps No Longer Here" should be a complete list of all of the tabs listed in the array and sorted by the rep name.
How the heck do I do this? I'm really having a problem comparing the tabs to the list array and then copying all of the non-empty rows to the "Reps No Longer Sheet"
I appreciate all the help...
Jeff
ADDED:
Here is what I have so far, but it just isn't working:
Private Sub Combinedata()
Dim ws As Worksheet
Dim wsMain As Worksheet
Dim DataRng As Range
Dim Rw As Long
Dim Cnt As Integer
Dim ar As Variant
Dim Last As Integer
Cnt = 1
Set ws = Worksheets("Total Tabs")
Set wsMain = Worksheets("Reps No Longer Here")
wsMain.Cells.Clear
ar = ws.Range("A1", Range("A" & Rows.Count).End(xlUp))
Last = 1
For Each sh In ActiveWorkbook.Worksheets
For Each ArrayElement In ar 'Check if worksheet name is found in array
If ws.name <> wsMain.name Then
If Cnt = 1 Then
Set DataRng = ws.Cells(2, 1).CurrentRegion
DataRng.Copy wsMain.Cells(Cnt, 1)
Else: Rw = wsMain.Cells(Rows.Count, 1).End(xlUp).Row + 1
'don't copy header rows
DataRng.Offset(1, 0).Resize(DataRng.Rows.Count - 1, _
DataRng.Columns.Count).Copy ActiveSheet.Cells(Rw, 1)
End If
End If
Cnt = Cnt + 1
Last = Last + 1
Next ArrayElement
Next sh
End Sub
UPDATE - 7/3/14
This is the modified code. I'll highlight the line that is giving syntax error.
Sub CopyFrom2To1()
Dim Source As Range, Destination As Range
Dim i As Long, j As Long
Dim arArray As Variant
Set Source = Worksheets("Raw Data").Range("A1:N1")
Set Dest = Worksheets("Reps No Longer Here").Range("A1:N1")
arArray = Sheets("Total Tabs").Range("A1", Range("A" & Rows.Count).End(xlUp))
For i = 1 To 100
For j = 1 To 100
If Sheets(j).name = arArray(i, 1) Then
Source.Range("A" & j).Range("A" & j & ":N" & j).Copy ' A1:Z1 relative to A5 for e.g.
***Dest.Range("A" & i ":N" & i).Paste***
Exit For
End If
Next j
Next i
End Sub
The solution to a very similar problem was posted here yesterday by me. Have a look at the main loop in the code:
Sub CopyFrom2TO1()
Dim Source as Range, Destination as Range
Dim i as long, j as long
Set Source = Worksheets("Sheet1").Range("A1")
Set Dest = Worksheets("Sheet2").Range("A2")
for i = 1 to 100
for j = 1 to 100
if Dest.Cells(j,1) = Source.Cells(i,1) then
Source.Range("A" & j).Range("A1:Z1").Copy ' A1:Z1 relative to A5 for e.g.
Dest.Range("A"&i).Paste
Exit For
end if
next j
next i
End Sub
This would need slight modifications for your purpose, but it essentially does the same thing. Compares a column to a another column and copies wherever a match takes places.
Unable to find how to code: If Cell Value Equals Any of the Values in a Range