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
Related
I am trying to make a script that copy several specific columns, that are selected through a search loop, into a new woorkbook.
At the moment I have a loop to find all column positions of the the headers in a list and store these into an array. My question is how can I use all the values inside the array to copy them into a new workbook. At the moment I am looping through all the values and copying them individually.
How can make this copy and paste with one selection?
Dim c As Range
Dim dataheaderList As Range
Dim eachheader As Range
Dim sourceColumn As Range, targetColumn As Range
Dim myArray() As Variant
Dim x As Long
Dim i As Long
Set dataheaderList = Range("DataHeaderstoCopy") 'The range I want to look
i = -1
'Loop to find the positions of the headers from a existing list
For Each eachheader In dataheaderList
i = i + 1
ReDim Preserve myArray(i) As Variant
With ThisWorkbook.Names("Title2012Q2").RefersToRange
Set c = .Find(eachheader, LookIn:=xlValues)
myArray(i) = c.Column
End With
Next eachheader
'Loop to copy individually
i = 0
For x = LBound(myArray) To UBound(myArray)
i = i + 1
Set sourceColumn = Workbooks("SOR_Historical_Global_Entries_Example_2.xlsm").Worksheets(1).Columns(myArray(x))
Set targetColumn = Workbooks("Book1").Worksheets(1).Columns(i)
sourceColumn.Copy Destination:=targetColumn
Next x
End Sub
I am new to VBA and coding in general and I am being tasked with some coding that is proving difficult. I am trying to copy/transpose/paste values from a two-column PivotTable and I need it to paste vertically on another sheet and break on blanks. (see image) I need to copy each group in the PivotTable then transpose paste values vertically on a new worksheet. I believe I need to count populated rows (using an array?) until I get to a blank row then paste the group. I can picture what I need to do but all my coding attempts are way off. Except for the copy/paste, I have no clue how to code this. I cannot figure out how to capture each group of populated rows to be pasted.
' Copy a vertical range (on "FQNID_Sites" sheet) and paste to a horizontal range in column B (next blank row on "BH_FH" sheet)
Dim sourceSheet As Worksheet
Set sourceSheet = ThisWorkbook.Worksheets("FQNID_Sites")
Dim destinationSheet As Worksheet
Set destinationSheet = ThisWorkbook.Worksheets("BH_FH")
Dim cellToPasteTo As Range
' Need to loop through each group breaking on each siteNFID in column D (or break on blanks in column E?)
Set rng = Range("$D$2:$E$" & ActiveSheet.UsedRange.Rows.Count)
For Each cell In rng
Set cellToPasteTo = destinationSheet.Cells(destinationSheet.Rows.Count, "B").End(xlUp).Offset(1, 0)
If cell.Value = "" And Not IsNull(copyStart) Then
copyEnd = cell.Offset(-1, 0).Address
ElseIf cell.Value = "" Then
copyStart = cell.Offset(0, -1).Address
End If
If Not IsNull(copyStart) And Not IsNull(copyEnd) Then
sourceSheet.Range(copyStart & ":" & copyEnd).Select
Selection.Copy
cellToPasteTo.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Transpose:=True
End If
Next cell
Application.CutCopyMode = False
I need it to break on each siteNFID/FQNID then paste values for each group vertically in column B on the BH_FH worksheet.
Example of the input and expected output format
This code will work. Tested on similar data structure. I used the code sheet name in the code `Sheet1'. Change as needed.
Option Explicit
Sub runTranspose()
With Sheet1
Dim lastRow As Long
lastRow = .Cells(.Rows.Count, 4).End(xlUp).Row
'load range starts to transpose
Dim i As Long
For i = 2 To lastRow
If Len(.Cells(i, 5)) = 0 Then
Dim startTranspose As Range
If startTranspose Is Nothing Then
Set startTranspose = .Cells(i, 5)
Else
Set startTranspose = Union(startTranspose, .Cells(i, 5))
End If
End If
Next
Dim c As Range
For Each c In startTranspose
transposeData c
Next
End With
End Sub
Sub transposeData(r As Range)
With Sheet1
Dim nextRow As Long
nextRow = .Cells(.Rows.Count, 8).End(xlUp).Row + 1
Dim fullRange As Range
Set fullRange = Range(r.Offset(1, -1), r.Offset(1).End(xlDown))
Dim arr As Variant
arr = fullRange.Value
.Cells(nextRow,7).Value = r.offset(-1).Value 'to add label
.Cells(nextRow, 8).Resize(2, UBound(arr)).Value = Application.Transpose(arr)
End With
End Sub
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.
I'm trying to get data posted from a non-contiguous range into a row in a separate sheet. Before I built the non-contiguous range, this code worked perfectly. I've tried several things to loop through, but nothing I tried will work. It won't copy the ranged data as it sits. It's been years since I've actually done any coding and my re-learning curve seems to be holding me back.... the logic just isn't coming to me. Help!
Sub UpdateLogWorksheet()
Dim historyWks As Worksheet
Dim inputWks As Worksheet
Dim nextRow As Long
Dim oCol As Long
Dim myCopy As Range
Dim myTest As Range
Dim myData As Range
Dim lRsp As Long
Set inputWks = Worksheets("Input")
Set historyWks = Worksheets("DataEntry")
oCol = 3 'order info is pasted on data sheet, starting in this column
'check for duplicate VIN in database
If inputWks.Range("CheckVIN") = True Then
lRsp = MsgBox("VIN already in database. Update record?", vbQuestion + vbYesNo, "Duplicate VIN")
If lRsp = vbYes Then
UpdateLogRecord
Else
MsgBox "Please change VIN to a unique number."
End If
Else
'cells to copy from Input sheet - some contain formulas
Set myCopy = inputWks.Range("VehicleEntry") 'non-contiguous named range
With historyWks
nextRow = .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0).Row
End With
With inputWks
'mandatory fields are tested in hidden column
Set myTest = myCopy.Offset(0, 2)
If Application.Count(myTest) > 0 Then
MsgBox "Please fill in all the cells!"
Exit Sub
End If
End With
With historyWks
'enter date and time stamp in record
With .Cells(nextRow, "A")
.Value = Now
.NumberFormat = "mm/dd/yyyy hh:mm:ss"
End With
'enter user name in column B
.Cells(nextRow, "B").Value = Application.UserName
'copy the vehicle data and paste onto data sheet
myCopy.Copy
.Cells(nextRow, oCol).PasteSpecial Paste:=xlPasteValues, Transpose:=True
Application.CutCopyMode = False
End With
'clear input cells that contain constants
Clear
End If
End Sub
This is an example to explain how to achieve what you want. Please amend the code to suit your needs.
Let's say, I have a Sheet1 which looks like as shown below. The colored cells make up from my non contiguous range.
Now paste the code given below in a module and run it. The output will be generated in Sheet2 and Sheet3
Code
Sub Sample()
Dim rng As Range, aCell As Range
Dim MyAr() As Variant
Dim n As Long, i As Long
'~~> Change this to the relevant sheet
With Sheet1
'~~> Non Contiguous range
Set rng = .Range("A1:C1,B3:D3,C5:G5")
'~~> Get the count of cells in that range
n = rng.Cells.Count
'~~> Resize the array to hold the data
ReDim MyAr(1 To n)
n = 1
'~~> Store the values from that range into
'~~> the array
For Each aCell In rng.Cells
MyAr(n) = aCell.Value
n = n + 1
Next aCell
End With
'~~> Output the data in Sheet
'~~> Vertically Output to sheet 2
Sheet2.Cells(1, 1).Resize(UBound(MyAr), 1).Value = _
Application.WorksheetFunction.Transpose(MyAr)
'~~> Horizontally Output to sheet 3
Sheet3.Cells(1, 1).Resize(1, UBound(MyAr)).Value = _
MyAr
End Sub
Vertical Output
Horizontal Output
Hope the above example helps you in achieving what you want.
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