I am trying to write a VBA code to autofill range A1:A10000 with numbers 1 to 10000 but without entering 1 in A1 and 2 in A2 to create a range.
Basically, I need a code that looks like this:
Set fillRange = Worksheets("Sheet1").Range("A1:A10000")
(1,2).AutoFill Destination:=fillRange
Of course this does not work, but you get what it.
Writing and reading to/from the worksheet are some of the slowest actions you can perform. Writing time-efficient code means doing as much in memory as you can.
Try writing all your values into an array, then writing the whole thing to the worksheet in one shot, something like this:
Sub printRange(total As Integer)
Dim i, myRange() As Integer
ReDim myRange(1 To total)
For i = 1 To total:
myRange(i) = i
Next i
'Use Transpose to shift the 1d array into a column
Worksheets("Sheet1").Range("A1:A" & UBound(myRange)).Value = _
Application.WorksheetFunction.Transpose(myRange)
End Sub
For total = 10000, this pretty much runs instantly, even on a ten year old dinosaur desktop.
Dim fillRange As Range
Dim i As Long
Set fillRange = Worksheets("Sheet1").Range("A1:A10000")
With fillRange
For i = .Cells(1, 1).Row To .Cells(.Rows.Count, 1).Row
.Cells(i, 1).Value = i
Next i
End With 'fillRange
Or with AutoFill :
With Worksheets("Sheet1")
Range("A1").Value = 1
Range("A2").Value = 2
Range("A1:A2").AutoFill Destination:=Range("A1:A10000")
End With 'Worksheets("Sheet1")
this should be fast enough
you could use the following function
Function FillNumbers(rng As Range) As Variant
Dim i As Long
ReDim nmbrs(1 To rng.Rows.Count)
For i = 1 To UBound(nmbrs)
nmbrs(i) = i
Next
FillNumbers = Application.Transpose(nmbrs)
End Function
in the following manner
With Worksheets("Sheet1").Range("A1:A10000")
.Value = FillNumbers(.Cells)
End With
Can't you use a simple loop?
For i = 1 to 10000
Worksheets("Sheet1").Cells(i, 1) = i
Next i
Dim fillRagne As Range
Set fillRange = Range(Cells(1, 1), Cells(1000, 1))
For Each cell in fillRange
cell.value = cell.Row
Next cell
Related
I have a solution that works in Excel with a countif formula (with the help of another Stackoverflow user).
Essentially what this countif formula does is count the first instance of an ID that exclusively exists with the classification type "DC". For example, as you can see in my snippet, 2232 is marked with as it is only exists with the classification "DC". Whilst in the case of 2240 it is marked as 0 as there are multiple classifications possible.
The formula in column D is the following:
=IF(IF(B2<>"DC",0,AND(COUNTIF(C$2:C$28,C2)=COUNTIF(A$2:A$28,A2),COUNTIF(A$2:A2,A2)=1)),1,0)
The problem that I am experiencing is that this is an extremely slow formula to process for Excel -- it takes roughly ~10-15 mins to complete. The database that I am running this on contains of roughly 150k~ lines.
I was wondering if it was possible to do this same process in VBA, but a lot faster and more efficient than the current processing time.
So I am using the following piece of VBA code to try to recreate the same results:
Sub MarkUniqueID()
Dim Ary As Variant, Nary As Variant
Dim r As Long
With ThisWorkbook.Sheets("sheet1")
Ary = .Range("A2", .Range("A" & Rows.Count).End(xlUp)).Value2
End With
ReDim Nary(1 To UBound(Ary), 1 To 1)
With CreateObject("scripting.dictionary")
For r = 1 To UBound(Ary)
If Not .Exists(Ary(r, 1)) Then
.Add Ary(r, 1), Nothing
Nary(r, 1) = 1
Else
Nary(r, 1) = 0
End If
Next r
End With
ThisWorkbook.Sheets("sheet1").Range("E2").Resize(r).Value = Nary
End Sub
Which runs the process much smoother it takes only a few ~seconds of my original time, however, I am not sure how I can add one more criteria into my array (i.e. only exclusively consider "DC"), as now the results are not what I want (see below).
Any pointers would be much appreciated!
You can use another dictionary to track which ID's should be excluded:
Sub MarkUniqueID()
Dim Ary As Variant, Nary() As Long, cls, id, k
Dim r As Long, dictIn As Object, dictOut As Object
Dim ws As Worksheet
Set dictIn = CreateObject("scripting.dictionary")
Set dictOut = CreateObject("scripting.dictionary")
Set ws = ThisWorkbook.Sheets("sheet1")
'pick up the classification and ID
Ary = ws.Range("B2:C" & ws.Cells(ws.Rows.Count, "B").End(xlUp).Row).Value
ReDim Nary(1 To UBound(Ary), 1 To 1)
For r = 1 To UBound(Ary, 1)
cls = Ary(r, 1)
id = CStr(Ary(r, 2))
If cls = "DC" Then
If Not dictIn.exists(id) Then dictIn.Add id, r
Else
If Not dictOut.exists(id) Then dictOut.Add id, True
End If
Next r
For Each k In dictIn
If Not dictOut.exists(k) Then Nary(dictIn(k), 1) = 1
Next k
ws.Range("E2").Resize(UBound(Nary, 1)).Value = Nary
End Sub
I am getting to know Excel VBA. I have a working program that uses an action button on one sheet opens a source workbook and data worksheet, selects data and puts that into a second workbook and destination sheet. I then sort the data as needed and it looks like this
Destination sheet, sorted and annotated duplicates
I am now trying to select the data based on col 2 "B" where the items are duplicated and/or not duplicated then perform an action (send an email to the manager about the staff under their control). I can get an email to work but its selecting the data that I'm having trouble with.
the output data would be col 1 & col 3 to 5 e.g.
Dear Manager1,
you staff member/s listed below have achieved xyz
Person1 22/06/2017 11/08/2017 22/08/2017
Person11 22/06/2017 11/08/2017 22/08/2017
Person15 22/06/2017 11/08/2017 22/08/2017
congratulations....
So what I hope somebody can help me with is a clue how I get to look at the data in col 2
add the Row data required to an array or something then to check the next Row add it to the same something until it is different to the next Row Pause do the action then do the next iteration. Resulting in:
Manager1 .....Person 1,11,15action
Manager10 ..... Person 10action
Manager2 ..... Person 12,16,2,25,28action
Manager3 ..... Person 13,17,26,29,3action
until last line is reached.
I am so confused with arrays / lookups and loops I have lost the plot somewhere along the way.
I have a variable lastTmp which tells me the last line of data in the set, this will vary each month.
The Range is:
Set rng1 = Range("B5:B" & Cells(Rows.Count, "B").End(xlUp).row)
The last piece of my working code is:
Dim lp As Integer
lp = 1
For Each cell In rng1
If 1 < Application.CountIf(rng1, cell.Value) Then
With cell
.Offset(0, 4) = "duplicate : "
.Offset(0, 5) = lp
End With
Else
With cell
.Offset(0, 4) = "NOT duplicate : "
.Offset(0, 5) = 0
End With
End If
Next cell
You will be better placed to confront confusion if you do your indenting more logically. Related For / Next, If / Else / End If and With / End With should always be on the same indent level for easier reading. I rearranged your original code like this:-
For Each Cell In Rng1
If 1 < Application.CountIf(Rng1, Cell.Value) Then
With Cell
.Offset(0, 4) = "duplicate : "
.Offset(0, 5) = lp
End With
Else
With Cell
.Offset(0, 4) = "NOT duplicate : "
.Offset(0, 5) = 0
End With
End If
Next Cell
It now becomes apparent that the With Cell / End With need not be duplicated. I have further presumed that your variable lp actually was intended to hold the count. That made me arrive at the following compression of your code.
Dim Rng1 As Range
Dim Cell As Range
Dim lp As Integer
' the sheet isn't specified: uses the ActiveSheet
Set Rng1 = Range("B5:B" & Cells(Rows.Count, "B").End(xlUp).Row)
For Each Cell In Rng1
With Cell
lp = Application.CountIf(Rng1, .Value)
.Offset(0, 4) = IIf(lp, "", "NOT ") & "duplicate : "
.Offset(0, 5) = lp
End With
Next Cell
Consider using a Dictionary or Collection, whenever, checking for duplicates.
Here I use a Dictionary of Dictionaries to compile lists of Persons by Manager.
Sub ListManagerList1()
Dim cell As Range
Dim manager As String, person As String
Dim key As Variant
Dim dictManagers As Object
Set dictManagers = CreateObject("Scripting.Dictionary")
For Each cell In Range("B5:B" & Cells(Rows.Count, "B").End(xlUp).Row)
manager = cell.Value
person = cell.Offset(0, -1).Value
If Not dictManagers.Exists(manager) Then
dictManagers.Add manager, CreateObject("Scripting.Dictionary")
End If
If Not dictManagers(manager).Exists(person) Then
dictManagers(manager).Add person, vbNullString
End If
Next
For Each key In dictManagers
Debug.Print key & " -> "; Join(dictManagers(key).Keys(), ",")
Next
End Sub
I recommend you wanting Excel VBA Introduction Part 39 - Dictionaries
Assuming your data is as in the image
Then following code will give you result as in the image below.
Sub Demo()
Dim srcSht As Worksheet, destSht As Worksheet
Dim lastRow As Long, i As Long
Dim arr1(), arr2()
Dim dict As Object
Set dict = CreateObject("scripting.dictionary")
Set srcSht = ThisWorkbook.Sheets("Sheet2") 'change Sheet2 to your data sheet
Set destSht = ThisWorkbook.Sheets("Sheet1") 'change Sheet1 to your output sheet
arr1 = Application.Index(srcSht.Cells, [row(1:7000)], Array(2, 1)) 'See note below
arr2 = arr1
For i = 1 To UBound(arr1, 1)
If Not dict.exists(LCase$(arr1(i, 1))) Then
dict.Add LCase$(arr1(i, 1)), i
Else
arr2(i, 1) = vbNullString
arr2(dict.Item(LCase$(arr1(i, 1))), 2) = arr2(dict.Item(LCase$(arr1(i, 1))), 2) & "," & arr1(i, 2)
End If
Next
destSht.Range("A1").Resize(UBound(arr1, 1), UBound(arr1, 2)) = arr2 'display result
destSht.Columns("a").SpecialCells(xlBlanks).EntireRow.Delete
End Sub
Note : For details on assigning range to array see this.
I'm trying to use the trim function without success. After searching for the solution on this forum and other sources online I have seen many different approaches.
Is there no simple way of trimming a cell in VBA?
What I want is something like this:
Sub trimloop()
Dim row As Integer
row = 1
Do While Cells(row, 1) <> ""
Cells(row, 2) = trim(Cells(row, 2))
row = row + 1
Loop
So that when there is a value in column A (1) the value in column B (2) should be trimmed of any extra spaces. I just cant get this to work for me.
Appreciate any help/tips!
Regards
Jim
So i made the code a bit accurate and mistakeproof and it worked.
So i can recommend you to double check, if you have correct row and column values, because you probably targeting wrong cells. (cause your code is working)
Sub trimloop()
Dim row As Integer
Dim currentSheet As Worksheet
Set currentSheet = sheets("Sheet1")
row = 2
Do While currentSheet.Cells(row, 1) <> ""
currentSheet.Cells(row, 2).Value = Trim(currentSheet.Cells(row, 2).Value)
row = row + 1
Loop
End Sub
Use Application.WorksheetFunction.Trim(string)
Sub trimloop()
Dim row As Integer
row = 1
With ThisWorkbook.ActiveSheet
Do While .Cells(row, 1) <> ""
.Cells(row, 2) = Application.WorksheetFunction.Trim(.Cells(row, 2))
row = row + 1
Loop
End With
End Sub
this is the optimized version of your code, in case of big data sheets:
Option Explicit
Sub trimloop()
Dim row As Long, max As Long
Dim Data() As Variant
With ThisWorkbook.Sheets(1)
max = .Cells(1, 1).End(xlDown).row 'this does the same as your code, on first empty cell it stops
'the following finds the last un-empty cell of column(1):
'max= .cells(.rows.count,1).end(xlup).row
'copies values from sheet to memory (is faster for working with later)
Data = .Range(.Cells(1, 1), .Cells(max, 2)).Value2
'loop :
For row = 2 To max + 1
'work with memory instead of sheet
Data(row, 2) = Trim(Data(row, 2))
'for complete delete of all spaces use : = replace( StringName," ", "")
Next row
'write back to sheet
.Range(.Cells(1, 1), .Cells(max, 2)).Value2 = Data
End With
erase Data 'free memory
End Sub
Don't know if this overly simplified... but thought I would simply throw it out there this worked for me. The only predecessor step is you assign a "named range" to your workbook/worksheet/dataset ... name a data set and then iterate over the data set with this code
Sub forEachLoop()
For Each cell In Range("yourNamedRange")
cell.Value = Trim(cell.Value)
Next cell
End Sub
I have a very large amount of data A4:EW8000+ that I want to replace cells containing a zero with a blank cell. Formatting the cells is not an option as I need to retain the current format. I'm looking for the fastest way to replace zeros with blank cells.
I can do this with looping but its very slow. Below code:
Sub clearzero()
Dim rng As Range
For Each rng In Range("A1:EW10000")
If rng.Value = 0 Then
rng.Value = ""
End If
Next
End Sub
Is there an easy way I can do this without looping?
I tried the below code, but it doesn't seem to work correctly. It hangs Excel for a while (not responding) then it loops through the range and blanks every cell.
Sub RemoveZero()
Dim LastRow As Long
Const StartRow As Long = 2
LastRow = Cells.Find(What:="0", SearchOrder:=xlRows, SearchDirection:=xlPrevious, LookIn:=xlValues).Row
With Range("B:EW")
.Value = Range("B:EW").Value
.Replace "0", "0", xlWhole, , False
On Error Resume Next
.SpecialCells(xlConstants).Value = ""
.SpecialCells(xlFormulas).Value = 0
End With
End Sub
This is all the VBA you need to automate the replacements:
[a4:ew10000].Replace 0, "", 1
.
UPDATE
While the above is concise, the following is likely the fastest way possible. It takes less than a quarter of a second on my computer for your entire range:
Sub RemoveZero()
Dim i&, j&, v, r As Range
Set r = [a4:ew10000]
v = r.Value2
For i = 1 To UBound(v, 1)
For j = 1 To UBound(v, 2)
If Len(v(i, j)) Then
If v(i, j) = 0 Then r(i, j) = vbNullString
End If
Next
Next
End Sub
I have found that sometimes it is actually more expedient to cycle through the columns on bulk replace operations like this.
dim c as long
with worksheets("Sheet1")
with .cells(1, 1).currentregion
for c = 1 to .columns.count
with .columns(c)
.replace what:=0, replacement:=vbNullString, lookat:=xlWhole
end with
next c
end with
end with
Splitting the overall scope into several smaller operations can improve overall performance. My own experience with this is on somewhat larger data blocks (e.g. 142 columns × ~250K rows) and replacing NULL from an SQL feed not zeroes but this should help.
I have a column with nearly 100k and am trying to determine how many times a value occurs repeatedly in that column. I can do it row by row currently, but this is menial as a programmer, through something like =COUNTIF(D:D,D2). Yet that only returns D2 matches in column D.
I need to iterate through all values of D returning countif, therefore revealing all of the values repetitions in the column. I can remove duplicates later! So I have a dev. button a basic sub, or function (man this is new to me) and something along the lines of the most basic for loop ever. Just getting caught up on how to implement the COUNTIF() to to the loop properly.
Right now I'm looking at:
Sub doloop()
Dim i As Integer
i = 1
Do While i < D.Length
Cells(i, 8).Value =CountIf(D:D,D[i])
i = i + 1
Loop
End Sub
That code is incorrect obviously but it is where I'm at and may help for anyone more familiar with other languages.
Use Application.WorksheetFunction.CountIf() in your loop.
Private Sub doloop()
Dim lastRow As Long
Dim d As Double
Dim r As Range
Dim WS As Excel.Worksheet
Dim strValue As String
Dim lRow As Long
'Build your worksheet object
Set WS = ActiveWorkbook.Sheets("sheet1")
'Get the last used row in column A
lastRow = WS.Cells(WS.Rows.count, "D").End(xlUp).Row
'Build your range object to be searched
Set r = WS.Range("D1:D" & lastRow)
lRow = 1
WS.Activate
'Loop through the rows and do the search
Do While lRow <= lastRow
'First, get the value we will search for from the current row
strValue = WS.Range("D" & lRow).Value
'Return the count from the CountIf() worksheet function
d = Application.worksheetFunction.CountIf(r, strValue)
'Write that value to the current row
WS.Range("H" & lRow).Value = d
lRow = lRow + 1
Loop
End Sub
I believe you are trying to write the value to the cell, that is what the above does. FYI, if you want to put a formula into the cell, here is how that is done. Use this in place of WS.Range("H" & lRow).Value = d
WS.Range("H" & lRow).Formula = "=CountIf(D:D, D" & lRow & ")"
Sounds like you may want to look into using tables in Excel and capitalizing on their features like filtering and equation autofill. You may also be interested in using a PivotTable to do something very similar to what you're describing.
If you really want to go about this the programmatic way, I think the solution Matt gives answers your question about how to do this using CountIf. There's a big detriment to using CountIf though, in that it's not very computationally efficient. I don't think the code Matt posted will really be practical for processing the 100K rows mentioned in the OP (Application.ScreenUpdating = false would help some). Here's an alternative method that's a lot more efficient, but less intuitive, so you'll have to decide what suites your needs and what you feel conformable with.
Sub CountOccurances()
'Define Input and Output Ranges
'The best way to do this may very from case to case,
'So it should be addressed seperately
'Right now we'll assume current sheet rows 1-100K as OP specifies
Dim RInput, ROutput As Range
Set RInput = Range("D1:D100000")
Set ROutput = Range("E1:E100000")
'Define array for housing and processing range values
Dim A() As Variant
ReDim A(1 To RInput.Rows.Count, 0)
'Use Value2 as quicker more accurate value
A = RInput.Value2
'Create dictionary object
Set d = CreateObject("Scripting.Dictionary")
'Loop through array, adding new values and counting values as you go
For i = 1 To UBound(A)
If d.Exists(A(i, 1)) Then
d(A(i, 1)) = d(A(i, 1)) + 1
Else
d.Add A(i, 1), 1
End If
Next
'Overwrite original array values with count of that value
For i = 1 To UBound(A)
A(i, 1) = d(A(i, 1))
Next
'Write resulting array to output range
ROutput = A
End Sub
You can also modify this to include the removal of replicates you mentioned.
Sub CountOccurances_PrintOnce()
'Define Input and Output Ranges
'The best way to do this may very from case to case,
'So it should be addressed seperately
'Right now we'll assume current sheet rows 1-100K as OP specifies
Dim RInput, ROutput As Range
Set RInput = Range("D1:D100000")
Set ROutput = Range("F1:F9")
'Define array for housing and processing range values
Dim A() As Variant
ReDim A(1 To RInput.Rows.Count, 0)
'Use Value2 as quicker more accurate value
A = RInput.Value2
'Create dictionary object
Set d = CreateObject("Scripting.Dictionary")
'Loop through array, adding new values and counting values as you go
For i = 1 To UBound(A)
If d.Exists(A(i, 1)) Then
d(A(i, 1)) = d(A(i, 1)) + 1
Else
d.Add A(i, 1), 1
End If
Next
'Print results to VBA's immediate window
Dim sum As Double
For Each K In d.Keys
Debug.Print K & ": " & d(K)
sum = sum + d(K)
Next
Debug.Print "Total: " & sum
End Sub