I'm creating a UserForm with a textbox that the user will fill in with a list of names delimited by "; ". These names are found in Column D on my sheet. For each name, I'd like to copy and paste the whole row to another sheet and then delete the row in the original sheet. I am running into a couple of roadblocks that I haven't been able to solve.
Private Sub OK_Click()
Application.Volatile
Dim x As Integer
Dim PINamesArray As String
Dim size As Long
Dim SearchRange As Range
Dim FindRow As Range
Set SearchRange = Range("D5", Range("D2000").End(xlUp))
PINamesArray = Split(Me.PINames, "; ")
size = UBound(PINamesArray) - LBound(PINamesArray) + 1
For x = 1 To size
Set FindRow = SearchRange.Find(x, LookIn:=xlValues, LookAt:=xlWhole)
FindRow.Row
RTBM = FindRow.Row
RTBM.Copy
.Paste Worksheets("Dropped-NotSelected").Cells(ERow, 1)
RTBM.Delete Shift:xlShiftUp
End Sub
I want the Find function to look for the item in the delimited list that corresponds to that integer, not the integer itself.
I know that there are probably multiple aspects of this code that aren't right, but I'm having trouble finding good examples to base off of.
Give this a shot - I had to change some variables around (and fix a lot of weird typos you had going on), but this worked in my testing:
Option Explicit
Private Sub CommandButton1_Click()
Dim x As Long, ERow As Long
Dim PINamesArray As Variant
Dim size As Long
Dim SearchRange As Range
Dim FindRow As Long
Set SearchRange = Range("D5:D2000")
ERow = 1
PINamesArray = Split(Me.PINames, "; ")
size = UBound(PINamesArray) - LBound(PINamesArray) + 1
For x = 1 To size
On Error Resume Next
FindRow = SearchRange.Find(What:=PINamesArray(x)).Row
On Error GoTo 0
If FindRow <> 0 Then
Rows(FindRow).Copy
Worksheets("Dropped-NotSelected").Cells(ERow, 1).PasteSpecial
ERow = ERow + 1
Rows(FindRow).Delete Shift:=xlShiftUp
End If
Next x
End Sub
Related
I'm trying to use the split() function to loop through a specified range and split all strings when a ":" is encountered, and replace the existing value with the split value.
Dim k As Integer
Dim lRow as Long
Dim startZip_col As Long
Dim startZip_str As String
Dim startZip_result() As String
Dim startZip_decomposed As Variant
For k = 2 To lRow
startZip_str = Cells(k, startZip_col).Value
startZip_result = Split(startZip_str, ":")
For Each startZip_decomposed In startZip_result
Cells(k, startZip_col) = startZip_result(1)
Next
Next k
a example of the values i want to split are:
abc:1234
abc:5678
def:3456
tried debug.print to pinpoint where the errors are, but column value is correctly identified, loop looks fine, not sure where went wrong
Logic:
Where is lRow. startZip_col inititalized? Define and initialize your variables/Objects correctly.
Fully qualify the cells else it may refer to active sheet which may not be the sheet you think it is. For example ws.Cells(k, startZip_col).Value where ws is the relevant worksheet.
Before splitting, check for the existence of :
Code:
Option Explicit
Sub Sample()
Dim ws As Worksheet
Dim lRow As Long
Dim i As Long, j As Long
Dim ZipCol As Long
Dim ZipString As String
Dim ZipResult As Variant
'~~> Change this to the relevant sheet
Set ws = Sheet1
'~~> Change this to the releavant column
ZipCol = 1
With ws
'~~> Get the last row in Col A. Change to relevant column
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
For i = 2 To lRow
ZipString = .Cells(i, ZipCol).Value
'~~> Check if the string contains ":"
If InStr(1, ZipString, ":") Then
ZipResult = Split(ZipString, ":")
'.Cells(1, ZipCol) = ZipResult(1)
'~~> For testing
For j = LBound(ZipResult) To UBound(ZipResult)
Debug.Print ZipResult(j)
Next j
End If
Next i
End With
End Sub
I have two set of range named as LIST_KEY and LIST_CAT. In Column A, user will add some data which will contain one of the one of the text from LIST_KEY. I would like to get corresponding Category list from LIST_CAT depends upon the Key value
I am using below VBA code to achieve this. This include a Array formula.
Sub match()
Dim ss As Workbook
Dim test As Worksheet
Set ss = Excel.Workbooks("test.xlsm")
Set test = ss.Worksheets("Sheet1")
For i = 2 To test.Cells(Rows.Count, "A").End(xlUp).Row
Cells(i, "B").FormulaArray = "=INDEX(LIST_CAT,MATCH(TRUE,ISNUMBER(SEARCH(LIST_KEY,RC[-1])),0))"
Cells(i, "B").Formula = Cells(i, "B").Value
Next i
End Sub
This code works perfect if there is less data to fetch. But in my original use case, I will have around 8000 rows. Due to this large number of columns excel will go to not responding state after 2-3 minutes.
Instead of adding Array formula to column B, Is there anyway to convert that into VBA to run this faster. Sorry, I am new to this VBA stuff and dont have much experience
Try the following code, which uses arrays instead of worksheet formulas...
Option Explicit
Sub GetCategories()
Dim sourceWorkbook As Workbook
Set sourceWorkbook = Workbooks("test.xlsm")
Dim sourceWorksheet As Worksheet
Set sourceWorksheet = sourceWorkbook.Worksheets("Sheet1")
Dim lookupArray As Variant
lookupArray = sourceWorkbook.Names("LIST_KEY").RefersToRange.Value
Dim returnArray As Variant
returnArray = sourceWorkbook.Names("LIST_CAT").RefersToRange.Value
Dim tableArray As Variant
Dim lastRow As Long
With sourceWorksheet
lastRow = .Cells(.Rows.Count, "a").End(xlUp).Row
tableArray = .Range("A2:B" & lastRow).Value
End With
Dim desc As String
Dim i As Long
Dim j As Long
For i = LBound(tableArray, 1) To UBound(tableArray, 1)
desc = tableArray(i, 1)
For j = LBound(lookupArray, 1) To UBound(lookupArray, 1)
If InStr(1, desc, lookupArray(j, 1), vbTextCompare) > 0 Then
tableArray(i, 2) = returnArray(j, 1)
Exit For
End If
Next j
Next i
sourceWorksheet.Range("B2").Resize(UBound(tableArray, 1), 1).Value = Application.Index(tableArray, 0, 2)
End Sub
I have multiple cells ("positions") that require particular interior colors and values.
Each of these cells is associated with its own corresponding cell in another worksheet.
At the moment I have about 35 of these positions, but I may have 150 in the future, so adding these manually would be tedious! This is the code I have at the moment:
Dim FirstSheet As Worksheet
Dim Secondsheet As Worksheet
Dim position1 As Range
Dim position2 As Range
Dim position3 As Range
Dim lnCol As Long
Set FirstSheet As ThisWorkbook.Worksheets("FirstSheet")
Set SecondSheet As ThisWorkbook.Worksheets("SecondSheet")
Set position1 = Firstsheet.Range("G11")
Set position2 = Firstsheet.Range("F11")
Set Position3 = Firstsheet.Range("E11")
lnCol = 'this is a column number which is found earlier in the sub.
position1.Interior.Color = SecondSheet.Cells(8, lnCol).Interior.Color
position2.Interior.Color = SecondSheet.Cells(9, lnCol).Interior.Color
position3.Interior.Color = SecondSheet.Cells(10, lnCol).Interior.Color
position1.Offset(2, 0).Value = SecondSheet.Cells(8, lnCol).Value
position2.Offset(2, 0).Value = SecondSheet.Cells(9, lnCol).Value
position3.Offset(2, 0).Value = SecondSheet.Cells(10, lnCol).Value
Ideally, I would like a loop that would use two arrays that change at the same time, but I have no idea how to make it work! This is an example of what I would like to see:
For Each PositionVar In Array(position1, position2, position3)
PositionVar.Interior.Color = dynamicvariable.Interior.Color
PositionVar.Offset(2,0).Value = dynamicvariable.Value
Next PositionVar
Any help would be greatly appreciated!
Why dont you use two loops stacked together to solve this? For example:
for each rng in Array(Range1, Range2, Range3)
for each position in rng
'Do whatever you like with this Range
next position
next rng
You could use:
Option Explicit
Sub test()
Dim i As Long, y As Long, LastColumn As Long, Counter As Long, lnCol As Long
Dim ws1 As Worksheet, ws2 As Worksheet
Counter = 8
lnCol = 3 'Change value
With ThisWorkbook
'Set the sheet with positions
Set ws1 = .Worksheets("Sheet1")
'Set the second sheet
Set ws2 = .Worksheets("Sheet2")
End With
With ws1
'Find the LastColumn of row 11
LastColumn = .Cells(11, .Columns.Count).End(xlToLeft).Column
'Loop from the last column until column 5th
For i = LastColumn To 5 Step -1
With .Cells(11, i)
.Interior.Color = ws2.Cells(Counter, lnCol).Interior.Color
.Offset(2, 0).Value = ws2.Cells(Counter, lnCol).Value
End With
Counter = Counter + 1
Next i
End With
End Sub
NOTE
The limitation of using Last column is that if there is no values in row 11 you should use a variable instead of last column referring to the total value of column you want
Managed to find an answer by using arrays and a control variable. You just need to ensure that the corresponding variables are in the same order!. Hope this helps others.
Dim PositionArray As Variant
Dim SecondSheetArray As Variant
Dim i As Variant
PositionArray = Array(position1, position2, position3)
SecondSheetArray = Array(SecondSheet1, SecondSheet2, SecondSheet3)
For i = 0 To UBound(PositionArray)
PositionArray(i).Interior.Color = OverviewArray(i).Interior.Color
PositionArray(i).Offset(2, 0).Value = OverviewArray(i).Value
Next i
So I am learning VBA, I know how to program on Matlab and some C++. I am wondering how I can use the CountA to count all of the cells used on a specific row and only that row. ( I have multiple examples on ranges and columns but none on a Row only).I cannot use a range because I want to use this VBA in the future and this row will have a number of variables changing. I would also like to have the content(text) of those cells moved to another location with no spaces between them because right now they have three spaces between each used cell.
So far I have this code which isn't very much for the countA of the first row
Sub CountNonBlankCells()
Dim numcompanies As Integer
n = Sheet1.CountA(Rows(1))
Worksheets("start on this page").Range("B2") = n
End Sub
I have nothing for the part where I take that data from each cell to another location.
Sure you can use a Range. Your question is pretty broad, but for tutorial purpose ... here's a piece of code that counts the number of nonblank cells in a number of rows and shows you what's in each of them ...
Sub TestCount()
Dim mySht As Worksheet
Dim myRng As Range, oRow As Range
Dim lstRow As Long, lstCol As Long
Dim nUsed As Long
Dim iLoop As Long
Set mySht = Worksheets("Sheet13")
lstRow = mySht.Range("A1").End(xlDown).Row
lstCol = mySht.Range("A1").End(xlToRight).Column
Set myRng = mySht.Range(Cells(1, 1), Cells(lstRow, lstCol))
Debug.Print "Number of Rows is " & myRng.Rows.Count
For Each oRow In myRng.Rows
nUsed = Application.CountA(oRow)
For iLoop = 1 To nUsed
Debug.Print oRow.Cells(1, iLoop)
' assign oRow.Cells(1,iLoop) to something else here
Next iLoop
Next oRow
End Sub
As per your question I am assuming that you want to copy a complete row having blank cells to another location(row) but without blank cells.
I guess this is what you want.
Sub CountNonBlankCells()
Dim CurrentSh As Worksheet, TargetSh As Worksheet
Dim LastColumn As Long, count As Long
Dim MyRange As Range
Dim i As Long, temp As Long
Dim RowNum As Long
Set CurrentSh = ThisWorkbook.Worksheets("Sheet1")
Set TargetSh = ThisWorkbook.Worksheets("Sheet2")
RowNum = ActiveCell.Row
LastColumn = CurrentSh.Cells(RowNum, Columns.count).End(xlToLeft).Column
Set MyRange = CurrentSh.Rows(RowNum)
count = WorksheetFunction.CountA(MyRange)
temp = 1
For i = 1 To LastColumn
If Not IsEmpty(CurrentSh.Cells(RowNum, i)) Then
TargetSh.Cells(RowNum, temp).Value = CurrentSh.Cells(RowNum, i).Value
temp = temp + 1
End If
Next i
End Sub
Above code will copy active row in Sheet1 to Sheet2 at same row number without blank cells.
I have this bit of code below that is very close to what I am looking to do. How it works is you press the “List Word Issue” button in the excel spreadsheet and it scans all the text, cell by cell and row by row in column A, against a separate worksheet containing a list of words. If there is a match (between what’s in each individual cell in column 1) then it puts the word(s) that match into the adjacent row in column b.
Here (http://mintywhite.com/more/software-more/microsoft-excel-analyze-free-text-surveys-feedback-complaints-part-2) is a link to the article that I found the code on and a link (http://mintywhite.com/wp-content/uploads/2011/02/wordcount2.xls) to download the entire .xls spreadsheet.
What I am looking for is a simple change so there will not be a “match” unless the word appears at least 5 times in each cell/row in column A of the first worksheet.
Sub WordCount()
Dim vArray, WordIssue, ElementCounter As Variant
Dim lngLoop, lngLastRow As Long
Dim rngCell, rngStoplist As Range
ElementCounter = 2 'setting a default value for the counter
Worksheets(1).Activate
For Each rngCell In Worksheets("Word").Range("A3", Cells(Rows.Count, "A").End(xlUp))
vArray = Split(rngCell.Value, " ") 'spliting the value when there is a space
vrWordIssue = ""
ElementCounter = ElementCounter + 1 'increases the counter every loop
For lngLoop = LBound(vArray) To UBound(vArray)
If Application.WorksheetFunction.CountIf(Sheets("Issue").Range("A2:A" & Sheets("Issue").UsedRange.Rows.Count), vArray(lngLoop)) > 0 Then 'this is to test if the word exist in the Issue Sheet.
If vrWordIssue = "" Then
vrWordIssue = vArray(lngLoop) 'assigning the word
Else
If InStr(1, vrWordIssue, vArray(lngLoop)) = 0 Then 'a binary of comparison
vrWordIssue = vrWordIssue & ", " & vArray(lngLoop) 'this will concatinate words issue that exist in Issue Sheet
End If
End If
End If
Next lngLoop
Worksheets("Word").Range("B" & ElementCounter).Value = vrWordIssue 'entering the final word issue list into cell.
Next rngCell
End Sub
Quick comment about some of the code, if you're interested:
Dim lngLoop, lngLastRow As Long
lngLoop is actually Variant, not a long. Unfortunately, you cannot declare data types like this as you can in, say, C++.
You need to do this instead:
Dim lngLoop As Long, lngLastRow As Long
Also, WordIssue is never used. It is supposed to be vrWordIssue.
In fact, I would almost never use Variant for anything in VBA. I don't believe this author of that website knows a good amount of VBA. (at least, not when they wrote that)
That said, the first thing I would fix are the variables:
From:
Dim vArray, WordIssue, ElementCounter As Variant
Dim lngLoop, lngLastRow As Long
Dim rngCell, rngStoplist As Range
To:
Dim vArray As Variant
Dim vrWordIssue As String
Dim ElementCounter As Long
Dim lngLoop As Long, lngLastRow As Long
Dim rngCell As Range, rngStoplist As Range
And add Option Explicit to the top of the module. This will help with debugging.
...And you don't almost never have to use Activate for anything...
....you know what? I would just use a different approach entirely. I don't like this code to be honest.
I know it's not encouraged to provide a full-blown solution, but I don't like not-so-good code being spread around like that (from the website that Douglas linked, not necessarily that Douglas wrote this).
Here's what I would do. This checks against issue words with case-sensitivity, by the way.
Option Explicit
Public Type Issues
Issue As String
Count As Long
End Type
Const countTolerance As Long = 5
Public Sub WordIssues()
' Main Sub Procedure - calls other subs/functions
Dim sh As Excel.Worksheet
Dim iLastRow As Long, i As Long
Dim theIssues() As Issues
Set sh = ThisWorkbook.Worksheets("Word")
theIssues = getIssuesList()
iLastRow = sh.Cells(sh.Rows.Count, 1).End(xlUp).Row
' loop through worksheet Word
For i = 3 To iLastRow
Call evaluateIssues(sh.Cells(i, 1), theIssues)
Call clearIssuesCount(theIssues)
Next i
End Sub
Private Function getIssuesList() As Issues()
' returns a list of the issues as an array
Dim sh As Excel.Worksheet
Dim i As Long, iLastRow As Long
Dim theIssues() As Issues
Set sh = ThisWorkbook.Sheets("Issue")
iLastRow = sh.Cells(sh.Rows.Count, 1).End(xlUp).Row
ReDim theIssues(iLastRow - 2)
For i = 2 To iLastRow
theIssues(i - 2).Issue = sh.Cells(i, 1).Value
Next i
getIssuesList = theIssues
End Function
Private Sub clearIssuesCount(ByRef theIssues() As Issues)
Dim i As Long
For i = 0 To UBound(theIssues)
theIssues(i).Count = 0
Next i
End Sub
Private Sub evaluateIssues(ByRef r As Excel.Range, ByRef theIssues() As Issues)
Dim vArray As Variant
Dim i As Long, k As Long
Dim sIssues As String
vArray = Split(r.Value, " ")
' loop through words in cell, checking for issue words
For i = 0 To UBound(vArray)
For k = 0 To UBound(theIssues)
If (InStr(1, vArray(i), theIssues(k).Issue, vbBinaryCompare) > 0) Then
'increase the count of issue word
theIssues(k).Count = theIssues(k).Count + 1
End If
Next k
Next i
' loop through issue words and see if it meets tolerance
' if it does, add to the Word Issue cell to the right
For k = 0 To UBound(theIssues)
If (theIssues(k).Count >= countTolerance) Then
If (sIssues = vbNullString) Then
sIssues = theIssues(k).Issue
Else
sIssues = sIssues & ", " & theIssues(k).Issue
End If
End If
Next k
r.Offset(0, 1).Value = sIssues
End Sub