I am trying to assign a group of cells from two rows of two workbooks to two ranges. This information is used to do a comparison of the contents of both workbooks rows by ID.
I tried using "with" statements.
Dim aWorkbookBInfo() As Variant, aWorkbookAInfo() As Variant, rngWorkbookBToCompare As Range, rngWorkbookAToCompare As Range
Dim SumToCheck As Integer, FoundCell As Range, aCellValues() As Integer
ReDim aCellValues(LastSheetColumn - 1)
ReDim aWorkbookBInfo(LastSheetColumn - 1)
ReDim aWorkbookAInfo(LastSheetColumn - 1)
For i = 2 To LastSheetRow
Set FoundCell = Workbooks(WorkbookA).Sheets(SheetNameFromArray).Range("A:A").Find(What:=Workbooks(WorkbookB).Sheets(SheetNameFromArray).Cells(i, 1).Value)
If Not FoundCell Is Nothing Then
aCellValues(0) = 1
Workbooks(WorkbookB).Sheets(SheetNameFromArray).Cells(i, LastSheetColumn + 1).Value = FoundCell.Row
With Workbooks(WorkbookB).Sheets(SheetNameFromArray)
Set rngWorkbookBToCompare = Range(Cells(i, 2), Cells(i, LastSheetColumn))
End With
With Workbooks(WorkbookA).Sheets(SheetNameFromArray)
Set rngWorkbookAToCompare = Range(Cells(FoundCell.Row, 2), Cells(FoundCell.Row, LastSheetColumn))
End With
aWorkbookBInfo = rngWorkbookBToCompare
aWorkbookAInfo = rngWorkbookAToCompare
For j = 1 To LastSheetColumn - 1
If aWorkbookBInfo(1, j) = aWorkbookAInfo(1, j) Then
aCellValues(j) = 1
Else
aCellValues(j) = 0
End If
Next j
Else
End If
Next i
I would like to store the contents of the groups of cells from both workbooks without activating them, as I believe the process would be faster.
What I tried gets only the information of the active workbook instead of both workbooks.
Use a period . before Range or Cells references to fully qualify the Worksheet within the With...End With block.
With Workbooks(WorkbookB).Sheets(SheetNameFromArray)
Set rngWorkbookBToCompare = .Range(.Cells(i, 2), .Cells(i, LastSheetColumn))
End With
And again:
With Workbooks(WorkbookA).Sheets(SheetNameFromArray)
Set rngWorkbookAToCompare = .Range(.Cells(FoundCell.Row, 2), .Cells(FoundCell.Row, LastSheetColumn))
End With
Without the period, the With...End With has no effect. The ActiveSheet and ActiveWorkbook are implied since the Range and Cells calls are not fully qualified.
Related
I'm trying to copy to both debit/credit columns to other tables which match only the respective account value i.e. all Cash entries go to a Cash Account table, etc. I'll also need a way to omit those that have already been copied (so some check column will have to be referenced).
but I'm unclear how to translate this into VBA.
Here's a visual from the worksheet:
And my VBA code so far (MyAdd being a function that copies the range to another specified table)
Sub CopyRange()
For Each c In Range("Journal").Cells
If c.Value = "Cash" Then
If Range("Journal[#[Account 1]]").Value = "Cash" Then MyAdd "Cash_Account", Range(c.Offset(0, 2), c.Offset(0, 3))
Else: MyAdd "Cash_Account", Range(c.Offset(0, 1), c.Offset(0, 2))
Next
End Sub
I'm not sure why you'd want to do this. It would seem there is another end goal in mind. However, to do what you're asking in VBA can be done with the below code.
Sub GetNewColumnOfData()
Dim Table As ListObject
Dim TargetRange As Range
Dim Index As Long
Dim Values As Variant
Set Table = ThisWorkbook.Worksheets("Sheet3").ListObjects("Journal")
Set TargetRange = ThisWorkbook.Worksheets("Sheet3").Range("G1")
ReDim Values(1 To Table.ListRows.Count, 1 To 1)
For Index = 1 To Table.ListRows.Count
If Table.ListColumns("Account 1").DataBodyRange(Index, 1).Value = "Cash" Then
Values(Index, 1) = 1
ElseIf Table.ListColumns("Account 2").DataBodyRange(Index, 1).Value = "Cash" Then
Values(Index, 1) = 2
End If
Next Index
TargetRange.Resize(Table.ListRows.Count, 1).Value = Values
End Sub
Define your range/table names accordingly.
Using Zack's solution, I have created my solution this way - in case anyone wants to follow my work and improve upon it:
Sub GetNewColumnOfData()
Dim Table As ListObject
Dim TargetRange As Range
Dim Index As Long
Dim Account As String
Set Table = Range("Journal").ListObject
For Index = 1 To Table.ListRows.Count
If Not IsEmpty(Table.ListColumns("Account 1").DataBodyRange(Index, 1)) And IsEmpty(Table.ListColumns("*").DataBodyRange(Index, 1)) Then
Account = Table.ListColumns("Account 1").DataBodyRange(Index, 1).Value
Table.ListColumns("*").DataBodyRange(Index, 1).Value = "*"
MyAdd Account, Range(Table.ListColumns("Debit").DataBodyRange(Index, 1), Table.ListColumns("Credit").DataBodyRange(Index, 1))
ElseIf Not IsEmpty(Table.ListColumns("Account 2").DataBodyRange(Index, 1)) And IsEmpty(Table.ListColumns("*").DataBodyRange(Index, 1)) Then
Account = Table.ListColumns("Account 2").DataBodyRange(Index, 1).Value
Table.ListColumns("*").DataBodyRange(Index, 1).Value = "*"
MyAdd Account, Range(Table.ListColumns("Debit").DataBodyRange(Index, 1), Table.ListColumns("Credit").DataBodyRange(Index, 1))
End If
Next Index
End Sub
The MyAdd function was derived elsewhere on this site but I quote it here for ease of reference:
Sub MyAdd(ByVal strTableName As String, ByRef arrData As Variant)
Dim tbl As ListObject
Dim NewRow As ListRow
Set tbl = Range(strTableName).ListObject
Set NewRow = tbl.ListRows.Add(AlwaysInsert:=True)
' Handle Arrays and Ranges
If TypeName(arrData) = "Range" Then
NewRow.Range = arrData.Value
Else
NewRow.Range = arrData
End If
End Sub
Note I put this code in a module for the Workbook - and all the Ranges (tables/lists) are by default Workbook named ranges - hence accessible without needing to specify the sheets they are on.
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.
I'm trying to compare 2 (B and C) columns and write in column D match or no match at a push of a button in Excel but I'm new to VBA.
Here is some of my noobie tries. I know it's not dynamic but I'm stuck and I can't figure this out. So bear with me. Any help is much appreciated
Private Sub CommandButton1_Click()
Dim bothcolumns As Range, i As Integer
Set bothcolumns = [B2:B3000, C2:C3000]
With bothcolumns
For i = 1 To .Rows.Count
If Not StrComp(.Cells(i, 1), .Cells(i, 2), vbBinaryCompare) = 0 Then
With Value
For i = 1 To .Rows.Count
Range(.Cells(i, 5)).Value = "NoMatch"
Range(.Cells(i, 1), .Cells(i, 2)).Interior.ColorIndex = 3
Range("E1:E300").Value = "NoMatch"
ElseIf Not StrComp(.Cells(i, 1), .Cells(i, 2), vbBinaryCompare) = 1 Then
Range("E1:E300").Value = "Match"
End If
Next i
End With
End Sub
I don't know why is you error, but you have two loop for, and just one Next i. In addition your two loops have the same indent variable i.
This will iterate over all the used rows in the worksheet, and then compare the cells value of the columns 'B' and 'C'.
Try this code:
Private Sub CommandButton1_Click()
Dim rowsMax As Long
Dim i As Long
'This gets the total of used rows in the Worksheet
rowsMax = ThisWorkbook.ActiveSheet.UsedRange.Rows.Count
For i = 2 To rowsMax
If ThisWorkbook.ActiveSheet.Cells(i, 2).Value = ThisWorkbook.ActiveSheet.Cells(i, 3).Value Then
ThisWorkbook.ActiveSheet.Cells(i, 4).Value = "Match"
Else
ThisWorkbook.ActiveSheet.Cells(i, 4).Value = "No Match"
End If
Next
End Sub
Some Tips:
i and Value are not declared. From my experience i should declare As Long and Value should declare As Worskheet
With Value and the second For i = 1 To .Rows.Count do not close with Next i and End with respectively.
For i is better to use As Long to avoid errors when you deal with large data size.
You use .Cells BUT you dont use . before the Range so the range you what does not included in the upper With.
bothcolumns is declare As Range, BUT you use []which is wrong. Also you set the range BUT you miss the Sheet name (e.g. Set bothcolumns = ThisWorkbook.Worksheets("Sheet1").Range(...). In my opinion the best set is Set bothcolumns = ThisWorkbook.Worksheets("Sheet1").Range("B2:C3000")
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
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.