It has been a long time since I converted ranges to arrays. I have a list of 500 stock tickers in column D and associated stock names in column E. The list repeats itself every month, and I have 13 months of data. Problem is that sometimes the name changes when I add the new month's data, e.g., ATandT may become AT&T while the symbol remains "T". But the name must be consistent for all 13 months of data in the database. The following code uses two For Next loops to update the names in the prior 12 months of data with the newest names from the 13th month. It works well, but is obviously slow. If I convert the ranges to arrays, it will run much faster. Can someone give me a start with this. Thanks.
Sub changeRows()
Dim ws As Worksheet, rw As Long, lastrow As Long, tkr As String
Dim rw2 As Long, stk As String
Set ws = ActiveSheet
ws.Activate
lastrow = Cells(Rows.Count, "A").End(xlUp).Row
For rw2 = 11936 To lastrow
tkr = Cells(rw2, 4)
stk = Cells(rw2, 5)
For rw = 2 To 11935
If ws.Cells(rw, 4) = tkr Then
ws.Cells(rw, 5) = stk
End If
Next rw
Next rw2
End Sub
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 macro generating a new workbook, pasting a selection of data in it, making it an Excel table (listobject), adding data from another table, etc
Now I'm trying to loop through the entire table (working) looking in each column for identical cells to merge them
Dim tableName As String
Dim tblcofin As Listobject
Dim v As Long, w As Long
Dim Rg1 As Range, Rg2 As Range
tableName = "CO_FIN"
Set tblcofin = ActiveSheet.ListObjects(tableName)
For v = 1 To Range("CO_FIN").Columns.Count
For w = 1 To Range("CO_FIN").Rows.Count
Set Rg1 = tblcofin.DataBodyRange.Cells(w, v)
Set Rg2 = tblcofin.DataBodyRange.Cells(w + 1, v)
If Rg1 = Rg2 And Rg1 <> "" Then
tblcofin.Range(Rg1, Rg2).Merge
End If
Next w
Next v
Using Debug.Print lines I was able to confirm that it loops through my whole table, that it identified when 2 cells in the same columns are identical, but I always get an error message "Application-defined or object-defined error" (or another depending on the alternative I tried) for "Range(Rg1, Rg2).Merge"
I tried to:
- declare Rg1 & Rg2 as Variant rather than Range (setting them with or without adding .Address)
- use "Cells(Rg1, Rg2).Resize.Merge"
- and a multitude or other variations
I'm sure it's something very stupid, but though I usually make the point to find the solution by myself, after hours of trying and going through forums, I would really appreciate some advice!
(not sure how to upload a sample file, in case it may help)
I also tried this (adapted from J.A. Gomez) for just my 1st column, to no avail :( (still the same issue on the ".Merge" line...)
Dim myFirstRow As Long
Dim myLastRow As Long
Dim myFirstColumn As Long
Dim myLastColumn As Long
Dim myWorksheet As Worksheet
Dim iCounter As Long
Dim iCounter2 As Long
myFirstRow = 6
myFirstColumn = 2
myLastColumn = 5
myLastRow = 21
Set myWorksheet = Worksheets("Fin_conso")
With myWorksheet
For iCounter = myLastRow To myFirstRow Step -1
iCounter2 = iCounter - 1
If .Cells(iCounter, myFirstColumn).Value = Cells(iCounter - 1, myFirstColumn).Value Then
Debug.Print .Cells(iCounter, myFirstColumn).Address
.Range(.Cells(iCounter, myFirstColumn), .Cells(iCounter2, myFirstColumn)).Merge
End If
Next iCounter
End With
After hours spent looking for a solution, it came to me in a shocking revelation: it's just NOT POSSIBLE to merge cells in a Excel table (listobject), which must have values for filters etc.
Hope this experience can at least help others wasting time looking like me in the wrong direction!
So I had to unlist the table to make it a normal range, and just had to insert the excellent code from Pk found here:
Dim RgTable As Range
Dim FirstRow As Long, LastRow As Long, FirstCol As Long, LastCol As Long
Set RgTable = tblcofin.DataBodyRange 'To have a clear range to work from
'Unlist the tblcofin table to make it just a normal table (not Listobject)
tblcofin.Unlist
'Select the range where to merge identical cells
RgTable.Select
'Merge identical cells
Application.DisplayAlerts = False
Dim RgM As Range
MergeCells:
For Each RgM In Selection
If RgM.Value = RgM.Offset(1, 0).Value And RgM.Value <> "" Then
Range(RgM, RgM.Offset(1, 0)).Merge
Range(RgM, RgM.Offset(1, 0)).HorizontalAlignment = xlCenter
Range(RgM, RgM.Offset(1, 0)).VerticalAlignment = xlCenter
GoTo MergeCells
End If
Next
Application.DisplayAlerts = True
Thanks to the community: I've been learning so much ffrom stackoverflow forum over time. Appreciated!
I have a simple macro that includes a dynamic array which fills up upon conditions are met. The data populates the macro as it is supposed to be functioning until it paste the data onto the spreadsheet. Now, all data is pasted correctly except for date values. Date values are pasted erroneously from European format to American format onto the spreadsheet (i.e. dd-mm-yyyy to mm-dd-yyyy). So for instance a 1st march 2019 becomes a 3rd January 2019 on the spreadsheet. Note that either I format beforehand the destination files or not, the problem still occurs.
The array has 14 columns and only column 12-13 are date values.
Edit Summary
Shredded the code from irrelevant information; added images of results.
Following is the code
Sub Verification()
Dim NewWorkbook As String, NewWorksheet As String
Dim wb As Workbook, sh As Worksheet
Dim LoopCounter As Long
Dim NewEntryCounter As Long
Dim Cols As Long, Rows As Long
Dim r As Range
Dim arr As Variant, NewEntry() As Variant
Dim myRange As Integer
NewWorkbook = LCase(InputBox("What is the name of the new report?"))
NewWorksheet = LCase(InputBox("What is the name of the sheet?"))
Set wb = ThisWorkbook
Set sh = wb.Sheets("Renouvellement")
Cols = Workbooks(NewWorkbook).Sheets(NewWorksheet).Range(Workbooks(NewWorkbook).Sheets(NewWorksheet).Cells(1, 1), Workbooks(NewWorkbook).Sheets(NewWorksheet).Cells(1, 1).End(xlToRight)).Count
Rows = sh.Range(sh.Cells(1, 1), sh.Cells(1, 1).End(xlDown)).Count
For Each r In Workbooks(NewWorkbook).Sheets(NewWorksheet).Range("A2", Workbooks(NewWorkbook).Sheets(NewWorksheet).Range("A1").End(xlDown))
If (r.Offset(0, 21).Text = "Red" Or r.Offset(0, 21).Text = "Blue") And r.Offset(0, 17).Value >= 24 Then
arr = Application.VLookup(r.Value, sh.Range("A:A"), 1, 0)
If IsError(arr) Then
NewEntryCounter = NewEntryCounter + 1
ReDim Preserve NewEntry(1 To Cols, 1 To NewEntryCounter)
For LoopCounter = 1 To Cols
NewEntry(LoopCounter, NewEntryCounter) = r.Offset(0, LoopCounter - 1)
Next LoopCounter
Else
End Sub
Sample results from Local window
Sample results when transferring date values onto spreadsheet
As you can see the first value inserted is changed when transferring data from vba to spreadsheet. The second value is correctly transferred. The third is not, and so on.
Again, it's a bit difficult for me to understand exactly what you're doing, but it seems that a filter might be simpler, so far as the copying of relevant data is concerned.
In your code, you are making multiple calls to the worksheet, and multiple Redim Preserve operations on the VBA array. Those operations can be costly.
Perhaps that part of the code could be simplified (and sped up) with something like (obviously, you may need to change the worksheet and range variables):
Set ws = Worksheets("sheet1")
Set r = ws.Range("a1").CurrentRegion
With r
.AutoFilter field:=22, Criteria1:="red", Operator:=xlOr, Criteria2:="blue"
.AutoFilter field:=18, Criteria1:=">=24"
End With
r.SpecialCells(xlCellTypeVisible).Copy
'Paste somewhere
ws.ShowAllData
What I am trying to accomplish is this:
If any cells in columns AC-AF in my entire worksheet are blank, cut the entire row and paste to a new worksheet labeled "MissingShipping".
Code should adjust with the amount of rows, since that will never be the same.
From examples I have seen I don't understand where to insert the range of the cells I want to wade through.
I get the error
"Method 'Range' of object'_Worksheet'
on the line NewSetup.Range(Cells(Destinationrow, 1), Cells(Destinationrow, lastcolumn)).Select.
Option Explicit
Sub Shipping()
Dim MissingShipping As Worksheet
Set MissingShipping = Sheets.Add(After:=Sheets(Sheets.Count))
MissingShipping.Name = "MissingShipping"
Dim NewSetup As Worksheet
Dim lastcolumn As Integer
Dim Destinationrow As Integer
Dim lastrow As Long
Set NewSetup = Worksheets("NKItemBuildInfoResults")
Set MissingShipping = Worksheets("MissingShipping")
Destinationrow = 1
lastcolumn = NewSetup.Range("XFD1").End(xlToLeft).Column
lastrow = NewSetup.Range("A1048576").End(xlUp).Row
Dim i As Long
Dim j As Long
For i = lastrow To 1 Step -1
For j = 1 To lastcolumn
If NewSetup.Cells(i, j).Value = "" Then
NewSetup.Activate
NewSetup.Range(Cells(i, 1), Cells(i, lastcolumn)).Cut
MissingShipping.Activate
NewSetup.Range(Cells(Destinationrow, 1), Cells(Destinationrow, _
lastcolumn)).Select
ActiveSheet.Paste
NewSetup.Rows(i).Delete shift:=xlUp
Destinationrow = Destinationrow + 1
Exit For
End If
Next j
Next i
End Sub
G'day Nikki,
Welcome to the world of VBA! There are plenty of great resources on the internet to help you on your journey.
It's often easier and faster to work with a range inside your code instead of reading and writing to a sheet and selecting cells to mimic things that you would normally do if you were doing the job manually.
It's a good idea to get your head around the range object early on. It's handy for working with multiple worksheets.
The following is a good start with Ranges in Excel:
https://excelmacromastery.com/excel-vba-range-cells/
Another handy thing is a collection. If you had to store a bunch of things to work with later on, you can add them to a collection then iterate over them using a "For Each" loop. This is a good explanation of collections:
https://excelmacromastery.com/excel-vba-collections/
I had a quick look at your code and using the concept of Ranges and Collections, I have altered it to do what I think you were trying to do. I had to make a few assumptions as I haven't seen you sheet. I ran the code on a bunch of random rows on my computer to make sure it works. Consider the following:
Dim MissingShipping As Worksheet
Dim NewSetup As Worksheet
Dim rangeToCheck As Range
Dim cellsToCheck As Range
Dim targetRange As Range
Dim rw As Range 'rw is a row
Dim cl As Range 'cl is a cell
Dim rowColl As New Collection
Dim i As Long
Set NewSetup = Worksheets("NKItemBuildInfoResults")
Set MissingShipping = Worksheets("MissingShipping")
'Get the range of data to check
Set rangeToCheck = NewSetup.Range("A1").CurrentRegion
'For each row in the range
For Each rw In rangeToCheck.Rows
'For the last four cells in that row
Set cellsToCheck = rw.Cells(1, 29).Resize(1, 4)
For Each cl In cellsToCheck.Cells
'If the cell is empty
If cl.Value = "" Then
'Add the row to our collection of rows
rowColl.Add rw
'Exit the for loop because we only want to add the row once.
'There may be multiple empty cells.
Exit For
End If
'Check the next cell
Next cl
Next rw
'Now we have a collection of rows that meet the requirements that you were after
'Using the size collection of rows we made, we now know the size of the range
'we need to store the values
'We can set the size of the new range using rowColl.Count
'(that's the number of rows we have)
Set targetRange = MissingShipping.Range("A1").Resize(rowColl.Count, 32)
'Use i to step through the rows of our new range
i = 1
'For each row in our collection of rows
For Each rw In rowColl
'Use i to set the correct row in our target range an make it's value
'equal to the row we're looking at
targetRange.Rows(i) = rw.Value
'Increment i for next time
i = i + 1
Next rw
End Sub
Good luck! Hope this helps.
I am volunteering with an NGO, helping to create a SQL database for their weekly client attendance data. Data currently sits in an Excel spreadsheet.
I want to manipulate said spreadsheet to avoid having them change their process.
About this spreadsheet:
Each row represents a different client, while a range of 3 columns holds the following info (time in, time out, and units) for 5 days of the week. Right above the time in - units block, is the date of service that set of info pertains to (the dates are merged across that range normally, but I had to un-merge that). A screenshot is below for reference
What I need done:
I need to record each instance of every client's attendance on a separate row (in a different location - can be on the same sheet), matching the corresponding date of service, time in, time out, and units, to the name.
What I have tried:
I tried doing a For... Next loop with 3 counters for the 3 different ranges of info I need to look up, and declared the counters as ranges. I'm not sure if While... Wend is more appropriate here.
I also tried going the array way, but that's not coming together in my VBA.
I was also wondering if there is a datetime datatype that can be applied to Excel to eliminate having to match that additional range of values to the rest.
Side note: The greyed out cells on the sheet means the client isn't scheduled to attend on that day. So I need to include an If statement to skip cells that are blank.
The following code will do what you require, enough to get you started I hope - please note I have two sheets, Sheet1 (where data is stored) and Sheet2 (where data is moved to)
I have put the loops in where r = current row on sheet1, c = current column and then x is the counter for sheet2
r loop starts on row 3 and only goes to 5 for an example but you can find the last row and change the 5, or use a lastRow variable e.g. lastRow = .cells(.rows.count,1).end(xlup).row
This all assumes that the data is always in exactly the format shown in your screenshot. You can rearrange the output easily enough within the innermost IF and END IF chunk
Sub shift_me()
Dim r As Long
Dim c As Long
Dim x As Long
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Sheet2")
x = 1
With ThisWorkbook.Worksheets("Sheet1")
For r = 3 To 5
For c = 3 To 15 Step 3
If Not .Cells(r, c).Value2 = "" And Not .Cells(r, c).Value2 = 0 Then
ws.Cells(x, 1).Value2 = .Cells(r, 1).Value2
ws.Cells(x, 2).Value2 = .Cells(r, 2).Value2
ws.Cells(x, 3).Value2 = .Cells(r, c).Value2
ws.Cells(x, 4).Value2 = .Cells(r, c + 1).Value2
ws.Cells(x, 5).Value2 = .Cells(r, c + 2).Value2
ws.Cells(x, 6).Value2 = .Cells(1, c).Value2
x = x + 1
End If
Next c
Next r
End With
End Sub