Is there an apparent problem with the following codes? I want to loop through all listboxes and populate selected items.
Dim lRw As Integer
Dim iX As Integer, iY As Integer
Dim i As Integer
For i = 1 To 10
With ActiveSheet
.Columns(i + 10).ClearContents
End With
For iX = 0 To ListBox(i).ListCount - 1
If ListBox(i).Selected(iX) = True Then
With Sheet1
lRw = .Cells(.Rows.Count, i + 11).End(xlUp).Row + 1
For iY = 0 To ListBox(i).ColumnCount - 1
.Cells(lRw, iY + i).Value = ListBox(i).List(iX, iY)
Next iY
End With
End If
Next iX
Next i
With an unkown number of listboxes and an unknown number of selected items each, I would build a string with the results, then split the string on carriage returns Chr(10) for each line (each selected item in a listbox) and then use a text to columns to get everything in the correct cells. It would look like this:
Sub tgr()
Dim wsLists As Worksheet
Dim wsDest As Worksheet
Dim ctrl As OLEObject
Dim strOutput As String
Dim arrOutput() As String
Dim i As Long, j As Long
Set wsLists = Sheets("Sheet1") 'The sheet containing the listboxes
Set wsDest = Sheets("Sheet2") 'The sheet where the output will go
For Each ctrl In wsLists.OLEObjects
If TypeName(ctrl.Object) = "ListBox" Then
For i = 0 To ctrl.Object.ListCount - 1
If ctrl.Object.Selected(i) Then
If Len(strOutput) > 0 Then strOutput = strOutput & Chr(10)
For j = 0 To ctrl.Object.ColumnCount - 1
strOutput = strOutput & ctrl.Object.List(i, j) & vbTab
Next j
End If
Next i
End If
Next ctrl
If Len(strOutput) > 0 Then
wsDest.Range("K:T").ClearContents
arrOutput = Split(strOutput, Chr(10))
With wsDest.Cells(Rows.Count, "K").End(xlUp).Offset(1).Resize(UBound(arrOutput) - LBound(arrOutput) + 1)
.Value = Application.Transpose(arrOutput)
.TextToColumns Tab:=True
End With
Erase arrOutput
End If
End Sub
Related
I need help with writing some VBA that will read selected cells, ask for what you want to sort (for example you input FTA) and then it will take those three letters and the numbers following the "-" and put them into another sheet in the correct column. I will be adding more and more of these strings to cells and be able to run this multiple times till i use up all of the letter/number combinations. I have some code right now that just takes me to sheet labeled piece count and highlights cell E1. My sheets are called "Tracking log" and "Piece list"
Sub List()
Dim xLStr As String, xStrTmp As String
Dim xLStrLen As Long, xCount2 As Long, xCount As Long, I As Long, T As Long
Dim xCell As Range
Dim xArr
Dim xArr2
Dim xLnum As Long
On Error Resume Next
xLStr = Application.InputBox("What is the string to list:", , , , , , , 2) 'creates aplication box
If TypeName(xLStr) <> "String" Then Exit Sub '<> is not equal, "String" is the criteria
Application.ScreenUpdating = False 'nessecary for faster running time
xLStrLen = Len(xLStr) + Len(xLnum) 'sets string length to 7 in this case, len finds the length of a string
For Each xCell In Selection 'searches in the highlighted cells
xArr = Split(xCell.Value, xLStr) 'pulls the specific string that is to be searched
xCount = UBound(xArr)
If xCount > 0 Then
For I = 0 To xCount - 1
xCell.Copy (I)
Sheets("Piece list").Activate
Range("E1").Select
ActiveSheet.Paste
Next
' xArr2 = Split(xCell.Value, xLnum)
' xCount2 = UBound(xArr2)
' If xCount2 > 0 Then
' xStrTmp = ""
' For T = 0 To xCount2 - 1
' xStrTmp = xStrTmp & xArr2(T)
'
' xStrTmp = xStrTmp & xLStr
' Next
End If
Next
Application.ScreenUpdating = True
End Sub
[Here is my list of letters and numbers separated with "-" and commas
[Here is where I would like to put them sorted into the right column and by number in descending order
Here are my sheets
Split the strings into separate items. Then split the items into parts such that each item becomes a row with 3 columns e.g. ABC-123,ABC,123. Sort the data by columns 2 and 3 and then tabulate by column 1 onto a results sheet.
Option Explicit
Sub macro()
Dim wb As Workbook, ws As Worksheet, wsData As Worksheet, wsOut As Worksheet
Dim cell As Range, rng As Range, ar1 As Variant, ar2 As Variant
Dim n As Long, i As Long, r As Long, c As Long, iLastRow As Long
Dim s As String, prev As String
Set wb = ThisWorkbook
Set ws = wb.Sheets(1) ' data in col A
Set wsData = wb.Sheets(2) ' temp sheet
Set wsOut = wb.Sheets(3) ' output
' scan sheet 1, seperate and output to sheet 2
i = 1
iLastRow = ws.Cells(Rows.Count, 1).End(xlUp).Row
For r = 1 To iLastRow
s = ws.Cells(r, 1)
s = replace(s," ","") ' remove any spaces
If Len(s) > 0 Then
ar1 = Split(s, ",")
For n = 0 To UBound(ar1)
ar2 = Split(ar1(n), "-")
wsData.Cells(i, 1) = ar1(n)
wsData.Cells(i, 2) = ar2(0)
wsData.Cells(i, 3) = ar2(1)
i = i + 1
Next
End If
Next
iLastRow = i - 1
' sort on sheet 2
With wsData.Sort
.SortFields.Clear
.SetRange Range("A1:C" & iLastRow)
.SortFields.Add Key:=Range("B1:B" & iLastRow)
.SortFields.Add Key:=Range("C1:C" & iLastRow)
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
' tabulate onto sheet 3
c = 0
r = 0
prev = ""
For i = 1 To iLastRow
s = wsData.Cells(i, 2) 'abc
If s <> prev Then
' start new column
c = c + 1
wsOut.Cells(1, c) = s
wsOut.Cells(2, c) = wsData.Cells(i, 1)
r = 3
Else
wsOut.Cells(r, c) = wsData.Cells(i, 1)
r = r + 1
End If
prev = s
Next
MsgBox "Done"
End Sub
The IDs column in the first table contains multiple values in each cell that needs to be split. However, the unique issue is to retain both [name] and [description] info by ID into a new table.
.
The following VBA code performs the transpose paste option. This is what I am starting with to split cells with Chr(10), or new line as the delimiter:
Sub splitText()
'splits Text active cell using ALT+10 char as separator
Dim splitVals As Variant
Dim totalVals As Long
splitVals = Split(ActiveCell.Value, Chr(10))
totalVals = UBound(splitVals)
Range(Cells(ActiveCell.Row, ActiveCell.Column + 1), Cells(ActiveCell.Row, ActiveCell.Column + 1 + totalVals)).Value = splitVals
End Sub
Other than this, I am still searching for ideas.
Maybe this will help:
Sub splitText()
'splits Text active cell using ALT+10 char as separator
Dim splitVals As Variant
Dim lngRow As Long, lngEl As Long
With Sheet2
'Range A2:A5
For lngRow = 5 To 2 Step -1
splitVals = Split(.Range("A" & lngRow).Value, Chr(10))
'the first value
.Range("A" & lngRow).Value = splitVals(0)
'remaining values
For lngEl = 1 To UBound(splitVals)
.Rows(lngRow + lngEl).Insert
.Range("A" & lngRow + lngEl).Value = splitVals(lngEl)
.Range("B" & lngRow + lngEl & ":C" & lngRow + lngEl).Value = .Range("B" & lngRow & ":C" & lngRow).Value
Next lngEl
Next lngRow
End With
End Sub
Change Sheet Code/Name and Range as necessary.
Before:
After:
It's a bit more involved than your solution because you have to insert the correct number of rows below the targeted cell and then copy the IDs and the other data into the new rows. Here's an example to help you along.
There's a little "trickery" I'm using when I calculate the offset value. I'm doing this because you can assume that all arrays from the Split function will begin indexing at 0, but my personal habit is to write code that can work with either a 0 or 1 lower bound. Calculating and using an offset makes it all work for the loops and indexes.
Option Explicit
Sub test()
SplitText ActiveCell
End Sub
Sub SplitText(ByRef idCell As Range)
Dim splitVals As Variant
Dim totalVals As Long
splitVals = Split(idCell.Value, Chr(10))
If LBound(splitVals) = -1 Then
'--- the split character wasn't found, so exit
Exit Sub
End If
Dim offset As Long
offset = IIf(LBound(splitVals) = 0, 1, 0)
totalVals = UBound(splitVals) + offset
Dim idSheet As Worksheet
Set idSheet = idCell.Parent
Dim idRow As Long
idRow = idCell.Row
'--- insert the number of rows BELOW the idCell to hold all
' the split values
Dim i As Long
For i = 1 To totalVals - 1
idSheet.Rows(idRow + 1).Insert
Next i
'--- now add the IDs to all the rows and copy the other columns down
Const TOTAL_COLUMNS As Long = 3
Dim j As Long
Dim startIndex As Long
startIndex = LBound(splitVals) + offset
For i = startIndex To totalVals
idCell.Cells(i, 1) = splitVals(i - offset)
For j = 2 To TOTAL_COLUMNS
idCell.Cells(i, j) = idCell.Cells(1, j)
Next j
Next i
End Sub
I'm using the split function to split text using spaces. I have gotten my macro to split the text but I am having difficulties getting the loop to move to the next row below to split.
Sub Split_Text_Test1()
Dim Txt As String
Dim i As Integer
Dim FullName As Variant
Range("A1").Select
Txt = ActiveCell.Value
FullName = Split(Txt, " ")
For i = 0 To UBound(FullName)
Cells(1, i + 1).Value = FullName(i)
Next i
End Sub
You probably need to change the bit inside your loop thus as you are starting at A1. This assumes you want the entries in A2 and down. Not generally advisable to use Select/Activate, not very robust.
Edited to move across columns rather than down rows.
For i = 0 To UBound(FullName)
Range("A1").Offset(,i + 1).Value = FullName(i)
Next i
That said, you can avoid a loop altogether and use
Range("B1").Resize(, UBound(FullName) + 1).Value = FullName
In this case I would use a loop (and your solution was not that far from this):
Dim Txt As String
Dim i As Integer
Dim FullName As Variant
Dim R As Integer, C As Integer, MaxR as Integer
C = 1 ' can be another loop as well
For R = 1 to 1000
Txt = Trim(Cells(r,1).Value) ' will remove space from start and end
FullName = Split(Txt, " ")
For i = 0 To UBound(FullName)
Cells(R , C + 1 + i ).Value = FullName(i)
Next i
Next R
Sub Split_Text_Test1()
Dim Txt As String
Dim i As Integer
Dim FullName As Variant
Dim R As Integer, C As Integer
Range("A1").Select ' assumes that the cells below that are empty
Txt = ActiveCell.Value
FullName = Split(Txt, " ")
R = ActiveCell.Row
C = ActiveCell.Column
For i = 0 To UBound(FullName)
Cells(R + 1 + i, C).Value = FullName(i)
Next i
End Sub
I added few thing to your code, see if that serves your purpose. However, as SJR said Text to columns option in Data menu would do the same with less effort.
Sub Split_Text_Test1()
Dim Txt As String
Dim i As Integer
Dim FullName As Variant
Dim lastRow As Long
Dim myRange As Range
With ActiveSheet.UsedRange
lastRow = .Rows(.Rows.Count).Row
End With
Debug.Print lastRow
'Range("A1").Select
Set myRange = ActiveSheet.Range("A1", "A" & lastRow)
For Each cell In myRange
Txt = cell.Value
FullName = Split(Txt, " ")
For i = 0 To UBound(FullName)
Cells(cell.Row, i + 1).Value = FullName(i)
Next i
Next cell
End Sub
I'm new to vba and I've been trying to make the following code work:
convert = WorksheetFunction.SumIfs(Sheets("Convert").Range("C:C"), _
Sheets("Convert").Range("A:A"), Sheets("Vista").Range("L8"), _
Sheets("Convert").Range("D:D"), Sheets("Vista").Range("C2"), _
Sheets("Convert").Range("E:E"), Sheets("Vista").Range("AC4"))
Sheets("series").Range("L2").FormulaR1C1 = _
"=RC[-8]*"&convert&"
What I'm trying to do, is to put into a variable the result of a SUMIF formula, and use that same value to multiply it with the value of another cell.
It gives me an error of "Application-defined or object-defined error".
Thank you
Arrays Again
The Eliminator
Sub Eliminator()
Dim convert As Long
'Convert = WorksheetFunction.SumIfs(Sheets("Convert").Range("C:C"), _
Sheets("Convert").Range("A:A"), Sheets("Vista").Range("L8"), _
Sheets("Convert").Range("D:D"), Sheets("Vista").Range("C2"), _
Sheets("Convert").Range("E:E"), Sheets("Vista").Range("AC4"))
'e.g.
convert = 1000
Sheets("series").Range("L2").FormulaR1C1 = "=RC[-8]*" & convert
End Sub
Blah, Blah...
Now that we have concluded that the 'Convert' line is causing the error...
Since I use Excel 2003 and you have written the formula correctly, I can only guess that since SumIfs is something like an array formula it can't always be used successfully in VBA, or maybe never!? if you have error values in cells, there might be the solution, because VBA treats them as 'VBA Errors'.
The 'SumIfsless' Solution
So I provided another solution without using SumIfs. You can run it from VBA or any other worksheet. The 'str1' commented lines are for debugging purposes. You can uncomment them and see some 'subtotals' in the Immediate window.
Sub SumIfsArray()
'Variables
'Objects
Dim oRng As Range 'Range of the Sum Column (To Calculate First and Last Row)
'Arrays
Dim arrRngAddress As Variant 'Compare Addresses
Dim arrWs As Variant 'Worksheet Names
Dim arrCol As Variant 'Three Lookup Columns and the Sum Column
Dim arrRng As Variant 'Values of the Compare Addresses
Dim arrRanges As Variant 'The Ranges of the Four Columns
Dim arrArrays As Variant 'The Values of the Four Columns
'Other
Dim iCol As Integer 'Columns Counter
Dim lngFirst As Long 'First Usable Row of Data
Dim lngLast As Long 'Last Usable Row of Data
Dim lngRows As Long 'Number of Rows of Usable Data
Dim lngRow As Long 'Rows Counter
Dim lngSum As Long 'Sum of Values
Dim blnArr As Boolean 'True if all three conditions are met.
' 'Debug Variables
' Const c1 As String = "," 'Debug String Column Separator
' Const r1 As String = vbCr 'Debug String Row Separator
' Dim i1 As Integer 'Debug String Column Counter
' Dim lo1 As Long 'Debug String Rows Counter
' Dim str1 As String 'Debug String Concatenator
'Initialize
arrRngAddress = Array("L8", "C2", "AC4")
arrWs = Array("Convert", "Vista", "series")
arrCol = Array("A:A", "D:D", "E:E", "C:C")
'Program
ReDim arrRng(1 To 3)
With Worksheets(arrWs(1)) 'Worksheet "Vista"
For iCol = 1 To 3
arrRng(iCol) = .Range(arrRngAddress(iCol - 1)).Value
Next
End With
' str1 = "The Values"
' For i1 = 1 To 3: str1 = str1 & r1 & Space(1) & arrRng(i1)
' Next: Debug.Print str1
With Worksheets(arrWs(0)) 'Worksheet "Convert"
'Number of 'usable' rows of data
Set oRng = .Range(arrCol(3))
With oRng
If .Cells(1, 1) <> "" Then
lngFirst = 1
Else
lngFirst = .Cells(1, 1).End(xlDown).Row
End If
lngLast = .Cells(.Rows.Count, .Column).End(xlUp).Row
End With
Set oRng = Nothing
lngRows = lngLast - lngFirst + 1
'Array of Ranges
ReDim arrRanges(1 To 4)
For iCol = 1 To 4
arrRanges(iCol) = Range(Cells(lngFirst, Range(arrCol(iCol - 1)).Column), _
Cells(lngLast, Range(arrCol(iCol - 1)).Column)).Address
Next
' str1 = "The Ranges"
' For i1 = 1 To 4: str1 = str1 & r1 & Space(1) & arrRanges(i1)
' Next: Debug.Print str1
'Array of Arrays
ReDim arrArrays(1 To 4)
For iCol = 1 To 4
arrArrays(iCol) = .Range(arrRanges(iCol)).Value
Next
End With
' str1 = "Values of Ranges" & r1 & Space(1) & "A,D,E,C"
' For lo1 = 1 To lngRows: str1 = str1 & r1 & Space(1): For i1 = 1 To 4
' If i1 <> 1 Then
' str1 = str1 & c1 & arrArrays(i1)(lo1, 1)
' Else: str1 = str1 & arrArrays(i1)(lo1, 1)
' End If: Next: Next: Debug.Print str1
'Sum of Values
For lngRow = 1 To lngRows
For iCol = 1 To 3
If arrArrays(iCol)(lngRow, 1) = arrRng(iCol) Then
blnArr = True
Else
blnArr = False
Exit For
End If
Next
If blnArr = True Then
lngSum = lngSum + arrArrays(4)(lngRow, 1)
End If
Next
' str1 = "The Sum": str1 = str1 & r1 & Space(1) & lngSum
'Output
'Worksheet "series"
Worksheets(arrWs(2)).Range("L2").FormulaR1C1 = "=RC[-8]*" & lngSum
End Sub
P.S. I never ever use variable names with the same name as a worksheet name in the same workbook.
I need to do a vba code to compare texts in two columns and highlight matched texts in the second column. I started on the code and below is what I got so far. It works fine on the first row, how to modify the code to apply this for the entire table not just the first row. I'm new to VBA and any help would be great.
Sub Test1()
Dim strString$, x&
Dim rngCell As Range
strString = Range("G2").Value
Application.ScreenUpdating = False
For Each rngCell In Range("S2", Range("S" & Rows.Count).End(xlUp))
With rngCell
.Font.ColorIndex = 1
For x = 1 To Len(.Text) - Len(strString) Step 1
If Mid(.Text, x, Len(strString)) = strString Then .Characters(x, Len(strString)).Font.ColorIndex = 5
Next x
End With
Next rngCell
Application.ScreenUpdating = True
End Sub
If your code works correctly on the first row (I haven't tested it, so will just trust that you are correct), then the following is, I think, what you want to change:
Sub Test1()
Dim strString$, x&
Dim rngCell As Range
Application.ScreenUpdating = False
For Each rngCell In Range("S2", Range("S" & Rows.Count).End(xlUp))
With rngCell
.Font.ColorIndex = 1
strString = Cells(rngCell.Row, "G").Value
For x = 1 To Len(.Text) - Len(strString) Step 1
If Mid(.Text, x, Len(strString)) = strString Then .Characters(x, Len(strString)).Font.ColorIndex = 5
Next x
End With
Next rngCell
Application.ScreenUpdating = True
End Sub
i.e. move the calculation of strString inside the loop and base it on the value in column G of the row being processed.
I just gave someone this answer to a very similar question...
Sub ColorMatchingString()
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets(1)
Dim strTest As Collection: Set strTest = New Collection
Dim udRange As Range: Set udRange = ws.Range("AC2:AC311") 'Define Search Ranges
Dim myCell, myMatch, myString, i
Dim temp() As String, tempLength As Integer, stringLength As Integer
Dim startLength as Integer
For Each myMatch In udRange 'Build the collection with Search Range Values
strTest.Add myMatch.Value
Next myMatch
For Each myCell In ws.Range("A2:AB1125") 'Loop through each cell in range
temp() = Split(myCell.Text, ", ") 'define our temp array as "," delimited
startLength = 0
stringLength = 0
For i = 0 To UBound(temp) 'Loop through each item in temp array
tempLength = Len(temp(i))
stringLength = stringLength + tempLength + 2
For Each myString In strTest
'Below compares the temp array value to the collection value. If matched, color red.
If StrComp(temp(i), myString, vbTextCompare) = 0 Then
startLength = stringLength - tempLength - 1
myCell.Characters(startLength, tempLength).Font.Color = vbRed
End If
Next myString
Next i
Erase temp 'Always clear your array when it's defined in a loop
Next myCell
End Sub