Hi all! I have posted the same question previously but this one time is more explained with screenshots of the file.
I have 85 sheets (Sheet 1 screenshot for reference) and a specified range for each sheet (I12:N42). But this range consists formulas & cell references. What I am trying to do is:
Copying the data from all the 85 sheets with this range (I12:N42) except if "Qty = 0".
Pasting the copied data by PasteValues only to a master sheet.
PS: I tried to do the same thing using Power Query but it is quite slow so maybe VBA code will work faster on this.
Appreciate you guys!
Please, try the next code. It assumes that there are no other sheets except the master one and the mentioned 85 to copy from. If others, except them adding new conditions where the master one is skipped:
Sub copyNonZeroRowsInMaster()
Dim sh As Worksheet, shM As Worksheet, rng As Range, lastRow As Long, boolOK As Boolean
Dim arrRows, arrCopy, arr, arrSlice, count0 As Long, i As Long, k As Long
lastRow = 2 'the initial row where to paste
Set shM = ActiveWorkbook.Sheets("MASTER") 'please, use here the appropriate sheet name
shM.Range("A2:F10000").ClearContents
For Each sh In ActiveWorkbook.Sheets
If sh.Name <> shM.Name And sh.Name <> "TRACKING" Then 'if other sheets needs to be excepted, add them in the condition
Set rng = sh.Range("K13:K42") 'the range being the reference for non zero values
arrCopy = sh.Range("I13:N42").Value 'place all the range to be processed in an array, to make code faster
count0 = Application.CountIf(rng, 0) 'count the zero values (even from formulas) to redim in the next row
arr = rng.Value 'place the reference range in an array (also, to make the code faster)
If rng.Count - count0 = 0 Then GoTo OverProcessing
ReDim arrRows(1 To rng.Count - count0, 1 To 1) 'redim the array to keep the row numbers without 0 in K:K
k = 1: boolOK = False 'initialize the variable based on what the array keeping the rows to be copied is loaded
For i = 1 To UBound(arr) 'iterate beteen the array elements
If arr(i, 1) <> 0 Then
arrRows(k, 1) = i: k = k + 1 'fill the rows to be copied number in the array
boolOK = True
End If
Next i
If Not boolOK Then GoTo OverProcessing 'if there are only zero in all processed K:K range
arrSlice = Application.Index(arrCopy, arrRows, Array(1, 2, 3, 4, 5, 6)) 'create a slice array keeping only the non zero rows
'drop the slice array content at once:
shM.Range("A" & lastRow).Resize(IIf(k = 2, UBound(arrRows), UBound(arrSlice)), 6).Value = arrSlice
lastRow = shM.Range("A" & shM.Rows.Count).End(xlUp).Row + 1 'recalculate the last empty row
End If
OverProcessing:
Next
MsgBox "Ready..."
End Sub
The code is not tested (except the principle of working) and it should be very fast. Please, send some feedback after testing it.
Related
I am trying to write a VBA code where I want to populate DATA from a worksheet Range A to AQ spanning over multiple Rows. AQ contains Value "Open" or "Closed". I want to get the rows where AQ value is closed. I tried using the AutoFilter. This is working fine to an extent. But I have to use 2 For loops. One for Each Row and another for Each Column to populate Row wise, column by column into the list box
My Code as follows:
Note : Actual contents start from 6th Row where 6 contains the headers and data starts from 7th Row
Dim i As Long
Dim rowRange As Range
Dim AllData(1 To 1000, 1 To 43) As String
lstRecords.ColumnCount = 43
Set shDSR = mydata1.Sheets("DSR")
last_Row = shDSR.Cells(Rows.Count, 1).End(xlUp).Row
shDSR.AutoFilterMode = False
shDSR.Range("A6:AQ" & last_Row).AutoFilter Field:=43, Criteria1:="CLOSED"
Set rng = shDSR.Range("A6:AQ" & last_Row).SpecialCells(xlCellTypeVisible)
Dim filtrRow() As String
Dim rowCnt As Long
'Me.lstRecords.Clear
rowCnt = 0
If rng.Count > 0 Then
Me.lstRecords.Clear
Me.lstRecords.ColumnCount = rng.Columns.Count
For Each Row In rng.Rows
Me.lstRecords.AddItem
rowCnt = rowCnt +1
filterRow = Range(Row.Address)
'Me.lstRecords.List() = filterRow ''This throws error Type Mismatch so not using
For i = 1 To Row.Columns.Count
AllData(rowCnt, i) = Row.Cells(1, i).Value ''Move to Array
Me.lstRecords.List(rowCnt - 1, i - 1) = filterRow(1, i)'Buggy error when i = 11
Next
Next
'' Following segment works. Add data to Array and then populate ListBox from Array
Me.lstRecords.List() = AllData
Else
MsgBox "No data matches the filter criteria."
End If
Above Code has both approaches
a) Trying to load directly from excel Range (actually using filterRow, but can also directly use range with same issue). But, this approach stops always when i=11 with Invalid property error. I tried changing the data contents etc still same issue
Another Issue when Not taking the array based approach, only one line is added, so in affect only last line is available in the list box
b) Using the AllData array. I load all the row data (matching criteria) into the array and finally populate the listbox from array. THIS WORKS. But I do not like this approach
Can some one please point out where it is going wrong.
Thanks in advance
Problem is that filters create a non contiguous range consisting of areas which you have to iterate separately.
Option Explicit
Sub demo()
Dim mydata1 As Workbook, shDSR As Worksheet
Dim rng As Range, a As Range, r As Range
Dim last_row As Long, n As Long
Dim i As Long, rowCnt As Long
Dim ListData() As String
' change this
Set mydata1 = ThisWorkbook
Set shDSR = mydata1.Sheets("DSR")
With shDSR
.AutoFilterMode = False
last_row = .Cells(.Rows.Count, "AQ").End(xlUp).Row
.Range("A6:AQ" & last_row).AutoFilter Field:=43, Criteria1:="CLOSED"
Set rng = .Range("A6:AQ" & last_row).SpecialCells(xlCellTypeVisible)
.AutoFilterMode = False
End With
' clear listbox
With Me.lstRecords
.Clear
.ColumnCount = rng.Columns.Count
End With
'iterate areas and rows to count visible rows
For Each a In rng.Areas
n = n + a.Rows.Count
Next
rowCnt = 0
If n > 1 Then
' size array
ReDim ListData(1 To n, 1 To rng.Columns.Count)
' fill array
For Each a In rng.Areas
For Each r In a.Rows
rowCnt = rowCnt + 1
For i = 1 To UBound(ListData, 2)
ListData(rowCnt, i) = r.Cells(1, i).Value ''Move to Array
Next
Next
Next
' populate ListBox from Array
Me.lstRecords.List() = ListData
Else
MsgBox "No data matches the filter criteria."
End If
End Sub
This question already has answers here:
Replace cells containing zero with blank
(2 answers)
Closed last year.
I need to run a macro that replace all the cells in an array that contain "0" only as value with a blank
At the same time, cells that contains 0 and other text/numbers eg. "Test01" should not be considered and left as they are
this is the code i wrote but it is really slow on a 3k row sheet
Set sht = ActiveWorkbook.Sheets("Nuova Base Dati")
sht.Activate
Set rng = Range(Range("B2"), Range("E" & sht.UsedRange.Rows.count))
For Each cell In rng
If cell.Value = "0" Then cell.Value = ""
Next
Any suggestion to make it quicker?
Please, use the next code. It uses two arrays and should be fast enough for a large range, too:
Sub ReplaceZero()
Dim shT As Worksheet, arrE, r As Long, c As Long, arrFin
Set shT = ActiveWorkbook.Sheets("Nuova Base Dati")
'place the range to be processed in an array (for faster iteration):
arrE = shT.Range(shT.Range("B2"), shT.Range("E" & shT.UsedRange.Rows.count)).Value2
ReDim arrFin(1 To UBound(arrE), 1 To UBound(arrE, 2)) 'set dimensions of the final array, keeping the processing result
For r = 1 To UBound(arrE) 'iterate between the array rows
For c = 1 To UBound(arrE, 2) 'iterate between the array columns
If arrE(r, c) = 0 Then
arrFin(r, c) = "" 'write a null string in case of zero
Else
arrFin(r, c) = arrE(r, c) 'keep the existing value, if not zero
End If
Next c
Next r
'Drop the processed array content, at once:
shT.Range("B2").resize(UBound(arrFin), UBound(arrFin, 2)).Value = arrFin
End Sub
The above code is fast, but in case of formula involved it will transform the formulas in their values...
Follow-up of Dynamically Hide/Unhide Multiple Ranges Using VBA With Minimal Lag, to provide further or more clear details.
I am creating a worksheet that uses formulas to auto populate what is essentially an order form based off of information chosen from a single reference row.
In the screenshot row #12 is being used to populate rows 15 to 31 with the relevant information. This is a total of 17 rows. There are two additional rows that have no formulas and are used for padding or manual entry of information.
I want is to dynamically hide or unhide rows in the 17 row block based off of the selections in the reference row so as to eliminate possible blank lines in the middle of each block.
There are a total of 35 reference rows each with 17 cell blocks being used in the worksheet.
In my original question I was using the below method to trigger the changes on a line by line basis. Which I've since learned looks for changes in the entire worksheet and not select ranges. Good for small datasets, not so much with large ones.
Private Sub_Worksheet_Change(ByVal Target As Range)
I used the code from the accepted answer to create multiple subs updating the lastR and firstR declarations to match the row blocks that I need to have hidden or unhidden, and then calling them from within a Private Sub Worksheet_Change event.
Sub Hide1()
Dim sh As Worksheet, lastR As Long, firstR As Long
Dim rng As Range, rngH As Range, arr, i As Long
Set sh = ActiveSheet 'use here the sheet you need
lastR = sh.Range("B" & sh.rows.Count).End(xlUp).row 'last row on B:B
firstR = 15 'first row of the range to be processed
Set rng = sh.Range("B" & firstR & ":B" & lastR)
rng.EntireRow.Hidden = False 'show all rows in the range
arr = rng.Value 'place the range in an array for faster iteration
For i = 1 To UBound(arr)
If arr(i, 1) = "" Then
If rngH Is Nothing Then 'set the range to keep the cells where the rows must be hidden
Set rngH = rng.cells(i, 1)
Else
Set rngH = Union(rngH, rng.cells(i, 1))
End If
End If
Next
'hide the rows at once:
If Not rngH Is Nothing Then rngH.EntireRow.Hidden = True
End Sub
This again gets slow because of the Worksheet_Change constantly checking the entire worksheet and not just the reference rows. This is my fault for not clearly explaining what I wanted the code to do.
So to break it down, I want to use the above code or something similar (because I understand it) in a Worksheet_Change event, but only when the reference rows are changed. Each of these reference rows begin with Run X (where X is the number of the shelving run within the store) in the first column, has two rows of descriptive data that need to remain unhidden beneath it, and then has 17 rows of auto populated data that require hiding/unhiding.
Please, try the next way. It assumes that all rows to be triggered by the event should have in column B:B a string pattern like "RUN " followed by 1, 2, 3 and so on. Based on that, the below solution will build an array able to be transformed in a range, the single one triggering the event:
Please, copy the next adapted Sub able to receive three parameters from the event call:
Sub Hide_Global(firstR As Long, lastR As Long, sh As Worksheet)
Dim rng As Range, rngH As Range, arr, i As Long
Set rng = sh.Range("B" & firstR & ":B" & lastR)
rng.EntireRow.Hidden = False 'show all rows in the range
arr = rng.Value 'place the range in an array for faster iteration
For i = 1 To UBound(arr)
If arr(i, 1) = "" Then
If rngH Is Nothing Then 'set the range to keep the cells where the rows must be hidden
Set rngH = rng.Cells(i, 1)
Else
Set rngH = Union(rngH, rng.Cells(i, 1)) 'create a Union range for all occurrences
End If
End If
Next
'hide the rows at once:
If Not rngH Is Nothing Then rngH.EntireRow.Hidden = True
End Sub
Please, copy the next event instead of the existing one:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim lastR As Long, rng As Range
lastR = Me.Range("B" & Me.Rows.Count).End(xlUp).Row 'last row in column B:B
'build the range to trigger the event using triggeredRng function:
Set rng = triggeredRng(Me.Range("B1:B" & lastR))
If Not Intersect(Target, rng) Is Nothing Then 'let the event running only for changes in the appropriate rows:
Application.EnableAnimations = False: Application.ScreenUpdating = False 'some optimization
Me.Calculate 'let the formulae to be updated
'send to the rows hiding Sub the range to be processed limits:
Hide_Global Target.Row + 3, Target.Row + 19, Me
Application.ScreenUpdating = True: Application.EnableAnimations = True
End If
End Sub
The following function is called by the above event code, building the range to trigger it:
Function triggeredRng(rng As Range) As Range 'it returns the range able to trigger the event
Dim i As Long, k As Long, arr, arrRows, rngAddr As String, lastR As Long
lastR = rng.Rows.Count 'last range row
arr = rng.Value 'place the range in an array, for faster iteration
ReDim arrRows(UBound(arr)) 'reDim initially the array to be sure that there are enough place for expected elements
For i = 12 To lastR 'iterate between the array elements:
If Left(arr(i, 1), 3) = "RUN" Then 'if cells with a pattern starting with "RUN" exist:
arrRows(k) = i: k = k + 1 'place the row number as an array element and increment k
End If
Next i
ReDim Preserve arrRows(k - 1) 'keep only the array not empty elements
rngAddr = "A" & Join(arrRows, ",A") 'make a string by joining the array in this way
Set triggeredRng = Me.Range(rngAddr).EntireRow 'build a discontinuous range using the above built string
End Function
The logic of the above (suggested) solution is the next: When a change take place in the sheet where the event exists, a range built only by rows containing "RUN x" in B:B column (where x =1, 1, 3 and so on), will condition the event to process a specific range. The existing Sub hiding the rows has been modified, in order to accept firstR and lastR parameters, according to the explained rule.
The code can be optimized by creating a list validated cell, which containing all the strings type "RUN x", to easily reach them when needed. If you think it would be necessary, I will show you how to do that.
Please, test the suggested solution and send some feedback.
I am now trying to creating several worksheets and copying data from an existing worksheet to the worksheet that I just created.
This is what I have tried so far:
Sub CreateTemplate()
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "CUST001"
Worksheets("Template").Cells.Copy Worksheets("CUST001").Cells
Worksheets("CUST001").Select
Range("C4") = "='CDE Information'!R[-2]C[-2]"
Range("C5") = "='CDE Information'!R[-3]C[-1]"
Range("C6") = "1111"
Range("C7") = "2222"
End Sub
This is an example of a table that I want to copy.
Table
I also want to create the worksheets and name them by the values of each row in column A.
So, it seems to me that I should do something with loops but I have no idea about that.
Can anyone help me out? Thank you in advance!
Welcome to stack. Try this:
Option Explicit
Sub copyWs()
Dim arr, j As Long
With Sheet1
arr = .Range("A1").CurrentRegion.Value2 'get all data in memory
For j = 1 To UBound(arr) 'traverse rows
.Copy After:=ActiveWorkbook.Sheets(Worksheets.Count) 'add ws after the last ws
Sheets(ActiveWorkbook.Sheets(Worksheets.Count).Index).Name = arr(j, 1) 'name the last added ws
Next j
End With
End Sub
Now that we already have an array with all data we can also copy only part of our data to a new sheet instead of copying the whole sheet. To achieve this we'll just create a blank sheet first:
Sheets.Add After:=ActiveWorkbook.Sheets(Worksheets.Count) 'add ws after the last ws
When iterating an array we'll use 2 "counter" variables. 1 to go trough the lines, 1 to go trough the columns.
Dim j As Long, i As Long 'initiate our counter vars
For j = 1 To UBound(arr) 'traverse rows
For i = 1 To UBound(arr, 2) 'traverse columns
'here we can access each cell by referencing our array(<rowCounter>, <columnCounter>
'e.g. arr(j,i) => if j = 1 and i = 1 we'll have the values of Cell A1
Next i
Next j
The "Ubound" function allows us to get the total nr of rows and columns.
Dim arr2
ReDim arr2(1 To 1, 1 To UBound(arr)) '=> we only need 1 line but all columns of the source, as we cannot dynamically size an array with the "dim", we redim
For j = 1 To UBound(arr) 'traverse rows
For i = 1 To UBound(arr, 2) 'traverse columns
'here we can access each cell by referencing our array(<rowCounter>, <columnCounter>
'e.g. arr(j,i) => if j = 1 and i = 1 we'll have the values of Cell A1
'we can dump these values anywhere in the activesheet, other sheet, other workbook, .. but to limit the number of interactions with our sheet object we can also create new, intermediant arrays
'e.g. we could now copy cel by cel to the new sheet => Sheets(arr(j,1).Range(... but this would create significant overhead
'so we'll use an intermediant array to store the full line
arr2(1, i) = arr(j, i)
Next i
'when we have all the columns we dumb to the sheet
With Sheets(arr(j, 1)) 'the with allows us the re-use the sheet name without typing it again
.Range(.Cells(1, 1), .Cells(UBound(arr2), UBound(arr2, 2))).Value2 = arr2 'the ubound function allows us to size the "range" to the same size as our array, once that's done we can just dumb it to the sheet
End With
Next j
I am attempting to run a VBA macro that iterates down about 67,000 rows with 100 columns in each row. For each of the cells in these rows, the value is compared against a column with 87 entries in another sheet. There are no errors noted when the code is run but Excel crashes every time. The odd thing is that the code seems to work; I have it set to mark each row in which a match is found and it does so before crashing. I have attempted to run it many times and it has gotten through between 800 and 11,000 rows before crashing, depending on the attempt.
My first suspect was memory overflow due to the volume of calculations but my system shows CPU utilization at 100% and memory usage around 50% while running this code:
Sub Verify()
Dim codes As String
Dim field As Object
For i = 2 To Sheets("DSaudit").Rows.Count
For Each field In Sheets("Dsaudit").Range(Cells(i, 12), Cells(i, 111))
r = 1
While r <= 87
codes = ThisWorkbook.Sheets("287 Denominator CPT").Cells(r, 1).Value
If field = codes Then
Cells(i, 112).Value = "True"
r = 88
Else
r = r + 1
End If
Wend
Next field
i = i + 1
Next i
End Sub
It should also be noted that I am still very new to VBA so it's likely I've made some sort of egregious rookie mistake. Can I make some alterations to this code to avoid a crash or should I scrap it and take a more efficient approach?
When ever possible iterate variant arrays. This limits the number of times vba needs to access the worksheet.
Every time the veil between vba and Excel is pierced cost time. This only pierces that veil 3 times not 9,031,385,088
Sub Verify()
With Sheets("DSaudit")
'Get last row of Data
Dim lastrow As Long
lastrow = .Cells(.Rows.Count, 12).End(xlUp).Row 'if column 12 ends before the last row of data change to column that has them all.
'Load Array with input Values
Dim rng As Variant
rng = .Range(.Cells(2, 12), .Cells(lastrow, 111)).Value
'Create output array
Dim outpt As Variant
ReDim outpt(1 To UBound(rng, 1), 1 To 1)
'Create Match array
Dim mtch As Variant
mtch = Worksheets("287 Denominator CPT").Range("A1:A87").Value
'Loop through first dimension(Row)
Dim i As Long
For i = LBound(rng, 1) To UBound(rng, 1)
'Loop second dimension(Column)
Dim j As Long
For j = LBound(rng, 2) To UBound(rng, 2)
'Loop Match array
Dim k As Long
For k = LBound(mtch, 1) To UBound(mtch, 1)
'If eqaul set value in output and exit the inner loop
If mtch(k, 1) = rng(i, j) Then
outpt(i, 1) = "True"
Exit For
End If
Next k
'If filled true then exit this for
If outpt(i, 1) = "True" Then Exit For
Next j
Next i
'Assign the values to the cells.
.Cells(2, 112).Resize(UBound(outpt, 1), 1).Value = outpt
End With
End Sub