I wrote a program using VBA which shown below. there was an array(ary) which contain(C,F,B,PC,PB). I create the loop to go through each variable in the array.
what I want to do with my code is I have a datasheet that includes that array values as categories. I want to assign each array values to p range. then execute data from the p range. then want to assign p to next array value and do the same.
but the problem is range p is firstly set ary(1)="C" and give the correct result. but after it becomes equal to "F" didn't work properly. it contains the same range previously gave. can anyone help me with this problem?
For i = 1 To UBound(ary)
cat = ary(i)
Set p = Nothing
Set c = Nothing
For Each c In Range("E:E")
If c.Value = cat Then
If p Is Nothing Then
Set p = c.Offset
Else
Set p = Union(p, c)
End If
End If
Next c
'get values
p.Offset(, -1).Copy Destination:=ws.Range("N" & Rows.Count).End(xlUp).Offset(1)
next i
The key error in your code is the idea that you might collect a range of non-consecutive cells and paste their value into a contiguous range. Excel can't do that. My code below collects qualifying values into an array and pastes that array into the target range.
The code below can't be exactly what you want because you didn't provide some vital information. However, please try it anyway with the aim of adapting it to your project.
Private Sub Review()
Dim Ws As Worksheet
Dim Rng As Range
Dim Rl As Long ' last row in column E
Dim Ary() As String
Dim Arr As Variant
Dim n As Long
Dim Cell As Range
Dim i As Long
Set Ws = Worksheets("Sheet1")
Ary = Split("C,F,B,PC,PB", ",") ' this array would be 0-based
Rl = Cells(Rows.Count, "E").End(xlUp).Row ' Range("E:E") has 1.4 million cells
Set Rng = Range(Cells(2, "E"), Cells(Rl, "E"))
For i = 0 To UBound(Ary)
ReDim Arr(1 To Rl)
n = 0
For Each Cell In Rng
If Cell.Value = Ary(i) Then
n = n + 1
Arr(n) = Cell.Offset(0, 1).Value
End If
Next Cell
If n Then
ReDim Preserve Arr(n)
'get values
Ws.Cells(Ws.Rows.Count, "N").End(xlUp).Offset(1) _
.Resize(UBound(Arr)).Value = Arr ' Application.Transpose(Arr)
End If
Next i
End Sub
This code works entirely on the ActiveSheet and then pastes the result to another sheet, named as "Sheet1". That isn't good practice. The better way would be to declare variables for both sheets and let the code refer to the variables so as to ensure that it has full control of which sheet it's working on at all times.
Set p = Union(p, c) will never be executed because it will only occur if p is NOT nothing, and Set p = Nothing is executed each time the outer loop iterates.
Related
I have to run the code twice to get the right answer.
The bug is somewhere in the for loop commented as "finds static.press cell location"
Sub find()
Dim A As Double
Dim B As Variant
Dim c As Integer
Dim x As Range
Dim cell As Range
Dim rng As Variant
Dim r As Variant
Dim Mx As Long
Dim i As Long
Dim target As Double
Set wks = Worksheets("comefri")
Set wkks = Worksheets("TEST")
Dim p As Long
'RPM INPUT
A = wkks.Range("C18").value
'Static Pressure Input
B = wkks.Range("C19").value
'copy comefri values to test sheet
Sheets("comefri").Range("A9:gs24").Copy Destination:=Sheets("test").Range("a1:gs16")
With test
' Row Numb used in rangelookup
c = Range("C20").value
d = Range(Cells(c, 102), Cells(c, 201))
For Each cell In [a2:gs16]
cell = WorksheetFunction.Round(cell, 1)
Next cell
'Finds RPM cell location
Set cell = Range("a:a").find(What:=A, LookAt:=xlWhole, MatchCase:=fasle, SearchFormat:=False)
Range("c20") = cell.row
'finds static.press cell location
target = B
Set rng = Range(Cells(c, 102), Cells(c, 201))
'rng.Offset(, 1).ClearContents
Mx = Application.Max(rng)
For Each B In rng
If Abs(target - B) < Mx Then
Mx = Abs(target - B)
i = B.row
p = B.Column
End If
Next B
Debug.Print i
Debug.Print p
Range("d19").value = p
Range("e19").value = i
End With
End Sub
The first time the code runs, I think it uses the values from previous inputs and the second time I run it, it uses the new inputs.
I think I need a line of code to clear old inputs.
The problem is that you pull the value of c from a cell value (Sheets("TEST").Range("C20")). You update the cell value (on this line: Range("c20") = cell.row), but don't update the value of c. As such, when you set your rng variable, it's still using the old c value.
To resolve this, instead of this:
Set rng = Range(Cells(c, 102), Cells(c, 201))
Use this:
Set rng = wkks.Range(wkks.Cells(cell.Row, 102), wkks.Cells(cell.Row,201))
Lastly some generic advice:
As Cyril already stated, use descriptive variable names instead of single letters
Once a variable is set in the code, use the variable instead of referencing worksheet cells
Use proper indenting for your code to make it easier to read and follow
Always fully qualify your range objects to avoid confusion
Use your worksheet objects that you set instead of referencing worksheets by their codename
I want to copy a range of cells (custom format) filled with time data (e.g. 8:00, 7:30, 5:45, ...) as text to write to another program through Application.SendKeys. When I grab the cells as they are, they're written out as e. g. 1.041666666 instead of 7:30. How do I copy or convert them to text? Trying to get the value/text from the whole range as I copy won't work, neither did attempts at looping through afterwards to change the values separately. There might be workarounds using clipboard, but I want to leave it untouched. Code right now:
DayArray = Application.ActiveSheet.Range("A1:E4")
For j = 1 To UBound(DayArray)
For k = 1 To 5 'fixed column count
DayArray(j, k)= DayArray(j, k).Text
Next k
Next j
(... SendKeys example)
Application.SendKeys DayArray(1, 1), True
Use the Format() Function. It returns a string in the format desired:
DayArray = Application.ActiveSheet.Range("A1:E4")
For j = 1 To UBound(DayArray)
For k = 1 To 5 'fixed column count
DayArray(j, k)= Format(DayArray(j, k),"h:mm")
Next k
Next j
Time Range to Strings in a 2D one-based Array
Try:
Dim ws As Worksheet: Set ws = ActiveSheet
Dim DayArray() As Variant: DayArray = ws.[TEXT(A1:E4,"h:mm")]
or just (for the ActiveSheet exclusively):
Dim DayArray() As Variant: DayArray = [TEXT(A1:E4,"h:mm")]
Or an Evaluate one-liner function...
Function GetTimeRange( _
ByVal rg As Range) _
As Variant
GetTimeRange = rg.Worksheet.Evaluate("TEXT(" & rg.Address & ",""h:mm"")")
End Function
... to be used e.g. in the following way:
Sub GetTimeRangeTEST()
Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets("Sheet1")
Dim rg As Range: Set rg = ws.Range("A1:E4")
Dim Data As Variant: Data = GetTimeRange(rg)
ws.Range("G1").Resize(UBound(Data, 1), UBound(Data, 2)).Value = Data
End Sub
This code works almost perfectly. The problem is it includes blank cells in its "matched" results. What do I need to change to make this code ignore blank cells? Below I will include an example of what is going on.
Sub MarkMatches()
Const TopLeftCell As String = "A2" ' change to match where your data are
Dim Rng As Range ' data range
Dim FirstRow As Long, FirstClm As Long
Dim Data As Variant ' original data (2-D)
Dim Arr As Variant ' data rearranged (1-D)
Dim Tmp As Variant ' working variable
Dim R As Long, R1 As Long ' row counters
Dim C As Long ' column counter
Dim Count() As String ' match counter
With Range(TopLeftCell)
FirstRow = .Row
FirstClm = .Column
End With
C = Cells(FirstRow, Columns.Count).End(xlToLeft).Column
Set Rng = Range(Cells(FirstRow, FirstClm), _
Cells(Rows.Count, FirstClm).End(xlUp).Offset(0, C - FirstClm))
Data = Rng.Value
ReDim Arr(1 To UBound(Data))
For R = 1 To UBound(Data)
ReDim Tmp(1 To UBound(Data, 2))
For C = 1 To UBound(Data, 2)
Tmp(C) = Data(R, C)
Next C
Arr(R) = Tmp
Next R
ReDim Count(1 To UBound(Arr))
For R = 1 To UBound(Arr) - 1
For R1 = R + 1 To UBound(Arr)
Tmp = 0
For C = 1 To UBound(Arr(R))
If Not IsError(Application.Match(Arr(R)(C), Arr(R1), 0)) Then
Tmp = Tmp + 1
End If
Next C
If Tmp > 0 Then ' change to suit
Tmp = Format(Tmp, "(0)") & ", "
Count(R) = Count(R) & CStr(R1 + FirstRow - 1) & Tmp
Count(R1) = Count(R1) & CStr(R + FirstRow - 1) & Tmp
End If
Next R1
Next R
For R = 1 To UBound(Count)
If Len(Count(R)) Then Count(R) = Left(Count(R), Len(Count(R)) - 2)
Next R
' set the output column here (2 columns right of the last data column)
' to avoid including this column in the evaluation
' it must be blank before a re-run
Set Rng = Rng.Resize(, 1).Offset(0, UBound(Data, 2) + 1)
Rng.Value = Application.Transpose(Count)
End Sub
Thank you #Variatus for the code and help so far!
I tried to work with your original code, but honestly I became very confused. My example below will illustrate some practices that could help (and those who may review your code later, including yourself!). So here's a list of comments:
Always use Option Explicit. Your code may already have this, but I'm listing it here for completeness sake.
Create variable names that describe what data it holds. Your code does a little of this, but some of the variable names are difficult to fit into the logic flow. My idea in coding is always to try and write self-documenting code. That way, it's nearly always clear what the code is trying to accomplish. Then I'll use comment for code blocks where it might be a bit less clear. (Don't fall into the trap of prefixing variable names with a "type" or something; it's ultimately not worth it.)
A clear description of the problem always helps. This is true not only to get help on SO, but also for yourself. My final comment to your post above, asking about the problem description really simplified everything. This includes describing what you want your output to show.
As per the problem description, you need to identify each unique item and keep track of which row you find that item so you can create a report later. A Dictionary is a perfect tool for this. Read up about how to use a Dictionary, but you should be able to follow what this block of code is doing here (even without all the previous declarations):
For Each cell In dataArea.Cells
If Not IsEmpty(cell) Then
If items.Exists(cell.Value) Then
'--- add this row to the list
rowList = items(cell.Value) & "," & cell.Row
items(cell.Value) = rowList
Else
'--- first time adding this value
items.Add cell.Value, cell.Row
End If
End If
Next cell
It's easy to see how the logic of this code follows the description of the problem. After that, it's just a matter of running through each row in the data area and checking each value on that row to see if duplicates exist on any other row. The full example solution is below for you to study and adjust to fit your situation.
Option Explicit
Sub IdentifyMatches()
Dim ws As Worksheet
Set ws = Sheet1
Dim dataArea As Range
Set dataArea = ws.Range("A1:F6")
Dim items As Dictionary
Set items = New Dictionary
'--- build the data set of all unique items, and make a note
' of which row the item appears.
' KEY = cell value
' VALUE = CSV list of row numbers
Dim rowList As String
Dim cell As Range
For Each cell In dataArea.Cells
If Not IsEmpty(cell) Then
If items.Exists(cell.Value) Then
'--- add this row to the list
rowList = items(cell.Value) & "," & cell.Row
items(cell.Value) = rowList
Else
'--- first time adding this value
items.Add cell.Value, cell.Row
End If
End If
Next cell
'--- now work through the data, row by row and make the report
Dim report As String
Dim duplicateCount As Variant
ReDim duplicateCount(1 To dataArea.Rows.Count)
Dim dataRow As Range
For Each dataRow In dataArea.Rows
Erase duplicateCount
ReDim duplicateCount(1 To dataArea.Rows.Count)
Dim rowNumber As Variant
For Each cell In dataRow.Cells
If items.Exists(cell.Value) Then
rowList = items(cell.Value)
Dim rowNumbers As Variant
rowNumbers = Split(rowList, ",")
For Each rowNumber In rowNumbers
If rowNumber <> cell.Row Then
duplicateCount(rowNumber) = duplicateCount(rowNumber) + 1
End If
Next rowNumber
End If
Next cell
report = vbNullString
For rowNumber = 1 To UBound(duplicateCount)
If duplicateCount(rowNumber) > 0 Then
report = report & rowNumber & "(" & duplicateCount(rowNumber) & ")" & ", "
End If
Next rowNumber
'--- display the report in the next column at the end of the data area
If Len(report) > 0 Then
report = Left$(report, Len(report) - 2) 'removes the trailing comma and space
dataRow.Cells(1, dataRow.Columns.Count + 1).Value = report
End If
Next dataRow
End Sub
I struggle with VBA and have spent a few days trying to find a solution to this problem. Essentially, I have two spreadsheets with large sets of data. Column K of "Design Mods" worksheet contains the same types of values as Column C of the "Output" Worksheet. I've been trying to get my script to do the following:
1. for each cell in column k of "Design Mods", check if there is a matching cell in column c of the "output" spreadsheet
2. if a match is found, then populate the cell in "Design Mods" to columns over with the information from column b of "Output"
Because of my lack of experience, I've only been able to setup the script below which only checks and pulls correctly for one cell.
I need it to check each cell against a range of other cells.
Any help/guidance would be very much appreciated.
Thank you very much!
Sub MatchValue_Test()
'Routine is meant to populate columns "Design Mods" Spreadsheet with affected calculations from the "Output" Spreadsheet
'Variables below refer to Design Mods spreadsheet
Dim designmod As Worksheet '<-- Design Mods worksheet that we are comparing to the Output Data
Dim DesignMod_DClrow As Integer '<-- Variable used to count to the last low in the DC Number Column of Design Mods Spreadsheet
Dim designmoddc As Range '<-- Variable used to identify the range of values being checked in Design Mods is the DC Numbers Column K from K4 to the end of the column
Dim valuetofind As String '<-- DC Number used as matching criteria between Design Mods spreadsheet and Output Data
'Test Variables for integrating references to from Output worksheet
Dim testset As Worksheet
Dim test2_lrow As Integer
Dim test As Range
Dim valuetofindw2 As String
'Variables below pertain the routine itself
Dim found As Boolean '<-- this condition has to be false to start the routine
'Start of Routine
found = False
'Definition of Data Ranges in Design Mods spreadsheet
Set designmod = ActiveWorkbook.Worksheets("Sheet1")
DesignMod_DClrow = designmod.Range("K4").End(xlDown).Row
Set designmoddc = designmod.Range("K4:K" & DesignMod_DClrow)
'Test variables for integrating values from Output worksheet
Set testset = ActiveWorkbook.Worksheets("Sheet2")
test2_lrow = testset.Range("C2").End(xlDown).Row
Set test = testset.Range("C2:C" & test2_lrow)
'Identify the value being matched against
valuetofind = designmod.Range("L4").Value '<-- the script wont run if I have this value set to a range, and I need to figure out get this to loop so I don't need a variable for every cell im checking against
'test variables to figure out if statement
valuetofindw2 = testset.Range("C2").Value
valuetofindw3 = testset.Range("B2").Value
valuetofindw4 = designmod.Range("K4")
'If Statements performing the comparison
For Each Cell In designmoddc
If Cell.Value = valuetofindw3 Then
found = True
End If
Next
If found = True Then
designmoddc.Cells.Offset(0, 2).Value = testset.Range("B2")
End If
End Sub
You did not answer my clarification questions...
I prepared a solution, able to work very fast (using arrays). Please back-up your workbook, because the code will rewrite the matching cases in column M:M.
Sub MatchValue_TestArrays()
Dim designMod As Worksheet, lastRowD As Long, testSet As Worksheet, lastRowT As Long
Dim arrDes As Variant, arrTest As Variant, d As Long, t As Long, boolFound As Boolean
Set designMod = Worksheets("Sheet1")
Set testSet = Worksheets("Sheet2")
lastRowD = designMod.Range("K" & Cells.Rows.Count).End(xlUp).Row
lastRowT = testSet.Range("C" & Cells.Rows.Count).End(xlUp).Row
arrDes = designMod.Range("K4:M" & lastRowD).value 'load the range in array
arrTest = testSet.Range("B2:C" & lastRowT).value
For d = 1 To UBound(arrDes, 1)
For t = 1 To UBound(arrTest, 1)
If arrDes(d, 1) = arrTest(t, 2) Then
arrDes(d, 3) = arrTest(t, 1)'fill the array third column (M:M) with values of B:B testSheet...
Exit For
End If
Next t
Next d
designMod.Range("K4:M" & lastRowD).value = arrDes' Drop the modified array
End Sub
Try the updated code, please. It searches now for all occurrences and put each one in a consecutive column:
Sub MatchValue_TestArrays_Extended()
Dim designMod As Worksheet, lastRowD As Long, testSet As Worksheet, lastRowT As Long
Dim arrDes As Variant, arrTest As Variant, d As Long, t As Long, col As Long
Set designMod = Worksheets("Design") ' Worksheets("Sheet1")
Set testSet = Worksheets("TestS") ' Worksheets("Sheet2")
lastRowD = designMod.Range("K" & Cells.Rows.Count).End(xlUp).Row
lastRowT = testSet.Range("C" & Cells.Rows.Count).End(xlUp).Row
arrDes = designMod.Range("K4:AQ" & lastRowD).value
arrTest = testSet.Range("B2:C" & lastRowT).value
For d = 1 To UBound(arrDes, 1)
col = 3 'the column where the occurrence will be put
For t = 1 To UBound(arrTest, 1)
If arrDes(d, 1) = arrTest(t, 2) Then
arrDes(d, col) = arrTest(t, 1): col = col + 1
End If
Next t
Next d
designMod.Range("K4:AQ" & lastRowD).value = arrDes
End Sub
Using Match() is fast when your data is on a worksheet:
Sub MatchValue_Test()
Dim wsDesign As Worksheet, wsOut As Worksheet, m, c As Range
Set wsDesign = ActiveWorkbook.Worksheets("Sheet1")
Set wsOut = ActiveWorkbook.Worksheets("Sheet2")
For Each c In wsDesign.Range(wsDesign.Range("K4"), _
wsDesign.Cells(Rows.Count, "k").End(xlUp)).Cells
m = Application.Match(c.Value, wsOut.Columns("C"), 0)
If Not IsError(m) Then
'if Match() found a hit then m will be the row number on sheet2
c.Offset(0, 2).Value = wsOut.Cells(m, "B").Value
End If
Next c
End Sub
UPDATE:
Alright, so i used the following code and it does what i need it to do, i.e check if the value is 0 and if its is, then delete the entire row. However i want to do this to multiple worksheets inside one workbook, one at a time. What the following code is doing is that it removes the zeros only from the current spreadsheet which is active by default when you open excel through the VBA script. here the working zero removal code:
Dim wsDCCTabA As Excel.Worksheet
Dim wsTempGtoS As Excel.Worksheet
Set wsDCCTabA = wbDCC.Worksheets("Login")
Set wsTempGtoS = wbCalc.Worksheets("All_TemporaryDifferences")
Dim LastRow As Long, n As Long
LastRow = wsTempGtoS.Range("E65536").End(xlUp).Row
For n = LastRow To 1 Step -1
If Cells(n, 5).Value = 0 Then
Cells(n, 5).EntireRow.Delete
End If
Next
What am i doing wrong? when i do the same thing for another worksheet inside the same workbook it doesnt do anything. I am using the following code to remove zeros from anohter worksheet:
Set wsPermGtoS = wbCalc.Worksheets("All_PermanentDifferences")
'delete rows with 0 description
Dim LastRow As Long, n As Long
LastRow = wsPermGtoS.Range("E65536").End(xlUp).Row
For n = LastRow To 1 Step -1
If Cells(n, 5).Value = 0 Then
Cells(n, 5).EntireRow.Delete
End If
Next
Any thoughts? or another way of doing the same thing?
ORIGINAL QUESTION:
I want to delete all the rows which have a zero in a particular column. I am using the following code but nothing seems to happen:
CurrRow = (Range("E65536").End(xlUp).Row)
For Count = StartRow To CurrRow
If wsDCCTabA.Range("E" & Count).Value = "0" Then
wsDCCTabA.Rows(Count).Delete
End If
Next
StartRow contains the starting row value
CurrRow contains the row value of the last used row
See if this helps:
Sub DelSomeRows()
Dim colNo As Long: colNo = 5 ' hardcoded to look in col 5
Dim ws As Worksheet: Set ws = ActiveSheet ' on the active sheet
Dim rgCol As Range
Set rgCol = ws.Columns(colNo) ' full col range (huge)
Set rgCol = Application.Intersect(ws.UsedRange, rgCol) ' shrink to nec size
Dim rgZeroCells As Range ' range to hold all the "0" cells (union of disjoint cells)
Dim rgCell As Range ' single cell to iterate
For Each rgCell In rgCol.Cells
If Not IsError(rgCell) Then
If rgCell.Value = "0" Then
If rgZeroCells Is Nothing Then
Set rgZeroCells = rgCell ' found 1st one, assign
Else
Set rgZeroCells = Union(rgZeroCells, rgCell) ' found another, append
End If
End If
End If
Next rgCell
If Not rgZeroCells Is Nothing Then
rgZeroCells.EntireRow.Delete ' deletes all the target rows at once
End If
End Sub
Once you delete a row, u need to minus the "Count" variable
CurrRow = (Range("E65536").End(xlUp).Row)
For Count = StartRow To CurrRow
If wsDCCTabA.Range("E" & Count).Value = "0" Then
wsDCCTabA.Rows(Count).Delete
' Add this line:
Count = Count - 1
End If
Next
I got it. For future reference, i used
ActiveWorkbook.Sheets("All_temporaryDifferences").Activate
and
ActiveWorkbook.Sheets("All_Permanentdifferences").Activate
You don't need to use ActiveWorkbook.Sheets("All_temporaryDifferences").Activate. In fact if the ActiveWorkbook is different from wbCalc you would get an error.
Your real problem is that you are using an unqualified reference to Cells(n, 5).Value. Unqualified means that you aren't specifying which sheet to use so it defaults to the active sheet. That may work sometimes but it is poor code. In your case it didn't work.
Instead you should always use qualified references. wsTempGtoS.Cells(n, 5).Value is a qualified reference. wsTempGtoS specifies which worksheet you want so VBA is not left guessing.
Dim LastRow As Long, n As Long
LastRow = wsTempGtoS.Range("E65536").End(xlUp).Row
For n = LastRow To 1 Step -1
If wsTempGtoS.Cells(n, 5).Value = 0 Then
wsTempGtoS.Cells(n, 5).EntireRow.Delete
End If
Next
This: CurrRow = (Range("E65536").End(xlUp).Row) is also an unqualified reference. Instead it should be CurrRow = wsDCCTabA.Range("E65536").End(xlUp).Row.