Anyone knows how to get the difference between the two cells with condition. My problem is that if Column W contains the value of FAILED, then I have to get the difference of Column P and Column Q and put the difference to Column Z. Then I have to do this up until the last row that has a data in Column W. I have this code so far:
If ws.Range("W3") = "FAILED" Then
ws.Range("Z3") = ws.Range("P3") - ws.Range("Q3")
Else
ws.Range("Z3") = ""
End If
ws.Range("Z3").Copy
ws.Range("Z3:Z" & GetLastRow(ws)).PasteSpecial xlPasteValues
Any help? Thanks!
Sub GetDiff()
Dim Ws As Worksheet, lRw As Long
Set Ws = ActiveSheet
Application.ScreenUpdating = False
With Ws
lRw = .Range("W" & Rows.Count).End(xlUp).Row
With .Range("Z3:Z" & lRw)
.Formula = "=IF(W3=""Failed"",SUM(P3)-SUM(Q3),0)"
.Calculate
DoEvents 'This will let the formula to calculate before converting it to values
.Value = .Value
End With
End With
Application.ScreenUpdating = True
End Sub
If you really want to do this in VBA then you could change your code to:
Sub calc()
Dim ws As Object
Set ws = ActiveSheet
Row = 3
Do
If WorksheetFunction.CountA(ActiveSheet.Rows(Row)) = 0 Then Exit Do 'exit loop if row is empy
If ws.Cells(Row, 23).Text = "FAILED" Then
ws.Cells(Row, 26) = ws.Cells(Row, 16) - ws.Cells(Row, 17)
Else
ws.Cells(Row, 26) = ""
End If
Row = Row + 1
Loop
End Sub
Notice I favored numeric references to columns.
But unless you plan to escalate to a more complex case, I would stick with a formula on the Z column:
=IF(W1="FAILED",P1-Q1,"")
Related
I can not manage to cleanse my data of the "empty" rows. There is no problem in deleting the "0" but those cells which are empty are not empty but have something like "null strings" in it.
Sub Reinigung()
Application.ScreenUpdating = False
Application.EnableEvents = False
ListeEnde3 = ThisWorkbook.Sheets("input").Cells(Rows.Count, 1).End(xlUp).Row
For Zeile1 = 2 To ListeEnde3
If ThisWorkbook.Sheets("input").Cells(Zeile1, 14) = "0" Or ThisWorkbook.Sheets("2018").Cells(Zeile1, 14) = "" Then
ThisWorkbook.Sheets("input").Rows(Zeile1).Delete
Zeile1 = Zeile1 - 1
Else
End If
Next
' ThisWorkbook.Sheets("import").Columns(14).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
That code just freezes my excel, if i leave out the
thisWorkbook.Sheets("2018").Cells(Zeile1, 14) = ""
part, it works and deletes all rows, where colum 14 contains a "0".
If I check the cells which appear blank with =isblank it returns "false". There is no "space" in the cell and no " ' ".
What to do?
edit
After the first tips my code looks like this now:
Sub Reinigung()
Dim ListeEnde3 As Long
Dim Zeile1 As Long
Application.ScreenUpdating = False
Application.EnableEvents = False
ListeEnde3 = ThisWorkbook.Sheets("import").Cells(Rows.Count, 1).End(xlUp).Row
For Zeile1 = ListeEnde3 To 2 Step -1
Set rngX = ThisWorkbook.Sheets("import").Cells(Zeile1, 14)
If (rngX = "0" Or rngX = "") Then 'or rngY = vbNullString
ThisWorkbook.Sheets("import").Rows(Zeile1).Delete
End If
Next Zeile1
' ThisWorkbook.Sheets("import").Columns(14).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
Excel still crashes / freezes (I waited for 5 minutes) but since the code runs "smoothly" with F8 I wanted to give it a shot with less data: It works!
If I am not reducing the data there are ~ 70000 rows to check. I let it run on 720 rows and it worked.
Any way to tweak the code in a way that it can handle the 70000+ rows? I didn't think that it would be too much.
Thanks!
You can use AutoFilter and delete the visible rows (not tested) :
Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets("import")
ws.UsedRange.AutoFilter 14, Array("=0", "="), xlFilterValues
ws.UsedRange.Offset(1).EntireRow.Delete
ws.AutoFilterMode = False
Another way is to simply use internal arrays and write out the new data set which has valid rows.
It is very fast.
If your dataset has formulas then you'll have to use extra code, but if it's constants only, then the below should do:
Sub Reinigung()
'Here I test with column E to Z, set Ranges appropriately
Application.ScreenUpdating = False
Application.EnableEvents = False
Dim ListeEnde3 As Long, x As Long, y As Long
'last row of data - set to column of non-blank data
ListeEnde3 = ThisWorkbook.Sheets("import").Cells(Rows.Count, 5).End(xlUp).Row
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("import")
Dim startCell As Range
'set to whatever cell is the upper left corner of data
Set startCell = ThisWorkbook.Sheets("import").Range("E1")
Dim arr As Variant, arrToPrint() As Variant
'Get rightmost column of data instead of hardcoding to "Z"
'write dataset into an array
arr = ws.Range(startCell, ws.Range("Z" & ListeEnde3)).Value
x = UBound(arr) - LBound(arr) + 1 'num of rows of data
y = UBound(arr, 2) - LBound(arr, 2) + 1 'num of columns of data
ReDim arrToPrint(1 To x, 1 To y) 'array to hold valid/undeleted data
Dim i As Long, j As Long, printCounter As Long, arrayColumnToCheck as Long
arrayColumnToCheck = 14 - startCell.Column + 1 '14 is column N
For i = 1 To x
If arr(i, arrayColumnToCheck ) <> 0 And arr(i, arrayColumnToCheck ) <> vbNullString Then
printCounter = printCounter + 1
For j = 1 To y
'put rows to keep in arrToPrint
arrToPrint(printCounter, j) = arr(i, j)
Next j
End If
Next i
'Print valid rows to keep - only values will print - no formulas
startCell.Resize(printCounter, y).Value = arrToPrint
'Delete the rows with zero & empty cells off the sheet
startCell.Offset(printCounter).Resize(ListeEnde3 - printCounter, y).Delete xlShiftUp
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
You can add IsEmpty to your code to check the cells filling
Sub Reinigung()
Application.ScreenUpdating = False
Application.EnableEvents = False
ListeEnde3 = ThisWorkbook.Sheets("input").Cells(Rows.Count, 1).End(xlUp).Row
For Zeile1 = 2 To ListeEnde3
Set rngX = ThisWorkbook.Sheets("input").Cells(Zeile1, 14)
Set rngY = ThisWorkbook.Sheets("2018").Cells(Zeile1, 14)
If (rngX = "0" And (Not IsEmpty(rngX))) Or (rngY = "") Then
ThisWorkbook.Sheets("input").Rows(Zeile1).Delete
Zeile1 = Zeile1 - 1
End If
Next
' ThisWorkbook.Sheets("import").Columns(14).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
NEVER a good idea to alter a loop counter: Zeile1 = Zeile1 - 1
Instead start at the end and use Step -1 in your loop to work backward.
You are in a infinite loop because the loop doesnt move forward. If Zeile=3 and there is a "" in row3 in the '2018' sheet, then it will always be stuck on the Zeile1 = 3 line. You will always be coming back to that "" on row 3 in '2018'sheet.
For Zeile1 = ListeEnde3 To 2 Step -1
Set rngX = ThisWorkbook.Sheets("input").Cells(Zeile1, 14)
Set rngY = ThisWorkbook.Sheets("2018").Cells(Zeile1, 14)
If (rngX = "0" Or rngY = "") Then 'or rngY = vbNullString
ThisWorkbook.Sheets("input").Rows(Zeile1).Delete
End If
Next Zeile1
I need to create a sub to consolidate some data. I have several rows (anywhere from 4k to 20k) that I need to consolidate and sum the values from each column (from C to N).
The input data looks like this:
input
For the output, it should sum the columns for each SKU (Column A) and delete the rest.
Like this:
output
It should be simple enough, but I can’t seem to come up with an appropriate solution. I tried using an array with a scripting dictionary but I can’t figure out how to store more than a single value for each key. Sample (unfinished) code:
Dim sArray As Variant
Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")
sArray = Range(currentRange).Value
For i = 1 To UBound(sArray, 1)
For j = 3 To UBound(sArray, 2)
If dict.exists(sArray(i, 1)) = False Then
dict.Add sArray(i, 1), sArray(i, j)
Else
'this part is very wrong:
dict(sArray(i, 1)) = dict(sArray(i, j)) + sArray(i, j)
End If
Next
Next
Thank you very much in advance!
Try this, It sums the values in Column Q:AB then paste them back and removes the duplicates.
Sub dupremove()
Dim ws As Worksheet
Dim lastrow As Long
Set ws = Sheets("Sheet12") ' Change to your sheet
With ws
lastrow = .Range("A" & .Rows.Count).End(xlUp).Row
With .Range("C2:N" & lastrow)
.Offset(, 14).FormulaR1C1 = "=SUMIF(C1,RC1,C[-14])"
.Value = .Offset(, 14).Value
.Offset(, 14).ClearContents
End With
With .Range("A1:N" & lastrow)
.Value = .Value
.RemoveDuplicates 1, xlYes
End With
End With
Before:
After:
I came up with the following solution instead and it took 30 seconds to run it (not entirely my own idea, borrowed some code from someplace else):
Sub dupes()
Dim MyRange As Range
Dim RowNum As Long
RowNum = 1
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Set MyRange = Range("A2:N14200") 'for test only, on the real sub it's dynamic
MyRange.Sort key1:=Range("A2"), order1:=xlAscending
For Each Row In MyRange
With Cells
While Cells(RowNum, 1) = Cells(RowNum + 1, 1) And Cells(RowNum + 1, 1) <> "" 'very important the second condition or it will continue to loop forever
For i = 3 To 14
Cells(RowNum, i) = Cells(RowNum, i) + Cells(RowNum + 1, i)
Next
Rows(RowNum + 1).EntireRow.Delete
Wend
End With
RowNum = RowNum + 1
Next
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
It's kinda messy but it does the trick. Thanks to everyone!
A strange question perhaps, but is there an alternative way of opening a workbook, searching for a particular reference in a column, and then pulling the data from a another column in that row using VBA, without using VLookup?
The table I am trying to get data from contains a mixture of numbers, text, dates, and the lookup value is often >13 digits long.
I sort of had something working with VLookup, but it was too inconsistent - every so often it would just break because the data type didn't match. An awful lot of 'type mismatch' or 'ByRef' errors - I'd get one right and then another breaks.
Unfortunately I don't know enough to know what to search to get me in the right direction.
If it helps explain what I'm trying to do, here's my code using VLookup that errors all the time:
Sub getData()
Application.EnableEvents = False
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlManual
Dim wb As Workbook, src As Workbook
Dim srcRange As Range
Dim InputString
Dim strStatus
Dim strStatusNum
Dim strD1
Dim I As Integer
Set wb = ActiveWorkbook
I = 7
Set src = Workbooks.Open("D:\Files\test2.xlsx", True, True)
With src.Sheets(1)
Set srcRange = .Range(.Range("A1"), .Range("H1").End(xlDown))
End With
Do While wb.ActiveSheet.Cells(I, 1) <> ""
'Makes sure src.Close is called if errors
'On Error Resume Next
InputString = wb.Worksheets("Sheet 1").Cells(I, 1)
strStatus = Application.VLookup(InputString, srcRange, 3, False)
strD1 = Application.VLookup(InputString, srcRange, 4, False)
'Convert strStatus to actual number e.g. "03. no d1"
strStatusNum = Left(strStatus, 2)
wb.Worksheets("Sheet 1").Cells(I, 4) = strStatusNum
If (strStatusNum <> 3) Then
wb.Worksheets("Sheet 1").Cells(I, 2) = "Not at 03. No Work Order"
ElseIf (strStatusNum = 3) And (strD1 <> "") Then
wb.Worksheets("Sheet 1").Cells(I, 2) = "D1 Received"
wb.Worksheets("Sheet 1").Cells(I, 3) = strD1
Else
wb.Worksheets("Sheet 1").Cells(I, 2) = "No D1"
End If
I = I + 1
Loop
src.Close (False)
Application.EnableEvents = True
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.Calculation = xlAutomatic
End Sub
EDIT: Corrected some syntax.
You can use the Find method of the Range object, in your case of the column. The return value is the first cell (represented as another Range object) with a matching value, unless there is no match at all. Then Nothing is returned.
On the returned (single cell) range you can use the EntireRow method to get a Range that represents all the cells on the row of the found cell. On the returned (row) range you can use the Cells method to select the cell matching the column in the same row, that you want to return (again represented as another Range object).
By the way, a more flexible alternative to VLOOKUP in workbook functions is a combination of INDEX and MATCH.
Untested but compiled:
Sub getData()
Dim src As Workbook
Dim srcRange As Range
Dim strStatus, strStatusNum, strD1
Dim m, rw As Range
Set rw = ActiveSheet.Rows(7)
Set src = Workbooks.Open("D:\Files\test2.xlsx", True, True)
With src.Sheets(1)
Set srcRange = .Range(.Range("A1"), .Range("H1").End(xlDown))
End With
Do While rw.Cells(1).Value <> ""
m = Application.Match(rw.Cells(1), srcRange.Columns(1), 0)
If Not IsError(m) Then 'proceed only if got match
strStatus = srcRange.Cells(m, 3).Value
strD1 = srcRange.Cells(m, 4).Value
strStatusNum = Left(strStatus, 2)
rw.Cells(4).Value = strStatusNum
If strStatusNum <> 3 Then
rw.Cells(2) = "Not at 03. No Work Order"
ElseIf strStatusNum = 3 And strD1 <> "" Then
rw.Cells(2) = "D1 Received"
rw.Cells(3) = strD1
Else
rw.Cells(2) = "No D1"
End If
End If
Set rw = rw.Offset(1, 0)
Loop
src.Close False
End Sub
you may be after this refactoring of your code
Sub getData()
Dim wbRng As Range, cell As Range, f As Range
Dim strStatus, strStatusNum, strD1
Application.EnableEvents = False
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlManual
With ActiveWorkbook.ActiveSheet
Set wbRng = .Range("A7:A" & WorksheetFunction.Max(7, .Cells(.Rows.count, 1).End(xlUp).Row)) '<--| set the range of values to be searched for
If WorksheetFunction.CountA(wbRng) = 0 Then Exit Sub '<--| exit if no values under row 7
Set wbRng = wbRng.SpecialCells(xlCellTypeConstants) '<--| narrow the range of values to be searched for down to not blank values only
End With
With Workbooks.Open("D:\Files\test2.xlsx", True, True).Sheets(1) '<--| open wanted workbook and reference its first sheet
With .Range("A1:A" & .Cells(.Rows.count, "H").End(xlUp).Row) '<--| reference its column A range from row 1 down to column H last not empty cell (this is your former "srcRange")
For Each cell In wbRng.SpecialCells(xlCellTypeConstants) '<--| loop through range of values to be searched for
Set f = .Find(what:=cell.Value, lookat:=xlWhole, LookIn:=xlValues) '<--| look referenced range for current value to be searched for
If Not f Is Nothing Then '<--| if found
strStatus = f.Offset(, 2).Value
strD1 = f.Offset(, 3).Value
'Convert strStatus to actual number e.g. "03. no d1"
strStatusNum = val(Left(strStatus, 2)) '<--| use 'Val()' function to convert string "03" to "3"
cell.Offset(, 3) = strStatusNum
Select Case True
Case strStatusNum <> 3
cell.Offset(, 1).Value = "Not at 03. No Work Order"
Case strStatusNum = 3 And (strD1 <> "")
cell.Offset(, 1).Resize(, 2).Value = Array("D1 Received", strD1)
Case Else
cell.Offset(, 1).Value = "No D1"
End Select
End If
Next
End With
.Parent.Close False
End With
Application.EnableEvents = True
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.Calculation = xlAutomatic
End Sub
I have a bit of code I've written and I'm having trouble with a certain line (Countifs statement). I haven't ever used this in VBA before so I think it might be something to do with Syntax? Please could someone take a look and let me know?
Thanks very much!
Sub TradeCopy()
'Declare Variables
Dim x As Worksheet
Dim y As Worksheet
Dim z As Range
Dim FirstRow As Integer
Dim LastRow As Long
Dim i As Long
Dim j As Long
Dim s As String
Dim t As String
Dim count As Long
Dim startdate As Long
On Error GoTo ERROREND
Application.DisplayAlerts = False
Application.EnableEvents = False
'Setting Values
s = ActiveWorkbook.Sheets("Name Creator").Range("B4")
Set x = ActiveWorkbook.Sheets(s)
t = ActiveWorkbook.Sheets("Name Creator").Range("B5")
Set y = ActiveWorkbook.Sheets(t)
startdate = ActiveWorkbook.Sheets("Name Creator").Range("B3")
'Find Cell where name occurs
Set z = x.Columns("A").Find(what:="trade id", LookIn:=xlValues, Lookat:=xlWhole)
'Return Start Row number
FirstRow = z.Row + 1
'Return Last Row number
LastRow = x.Range("A" & Rows.count).End(xlUp).Row
'Clear Existing Range of Values
y.Rows(2 & ":" & Rows.count).ClearContents
Below is the code giving problems, specifically the "count = " line when running debugger.
'Loop to highlight cells based on conditions
For i = FirstRow To LastRow
count = Application.WorksheetFunction.CountIfs(x.Range("B:B"), x.Range(i, 2), x.Range("L:L"), "<" & startdate)
Rest of code:
If (x.Cells(i, 21) = "Fra" Or x.Cells(i, 21) = "Swap" Or x.Cells(i, 21) = "Swaption" Or x.Cells(i, 21) = "BondOption" Or x.Cells(i, 21) = "CapFloor") And DateValue(x.Cells(i, 12).Value) > startdate And count <= 0 Then
x.Rows.Range("A" & i).Value.Interior.Color = vbRed
End If
Next i
'Loop to check for all 0 Cells and paste values
For j = FirstRow To LastRow
If x.Cells(j, 1).Interior.Color = vbRed Then
x.Rows.Range("A" & j).Value = y.Rows.Range("A" & j).Value
End If
Next j
'Remove Duplicates
y.Columns(2).RemoveDuplicates Columns:=Array(1)
Application.DisplayAlerts = True
Application.EnableEvents = True
MsgBox ("All Done!")
Exit Sub
ERROREND:
MsgBox ("Unexpected Error - Please Seek Assistance or Debug Code")
End Sub
I think you need to change .Range to .Cells in below:
count = Application.WorksheetFunction.CountIfs(x.Range("B:B"), x.Range(i, 2), x.Range("L:L"), "<" & startdate)
To:
count = Application.WorksheetFunction.CountIfs(x.Range("B:B"), x.Cells(i, 2), x.Range("L:L"), "<" & startdate)
I have 3 issues with the following piece of code:
Intention of code: I have a table of data, 4 columns (F,G, H and I) wide and X rows long (X is typically between 5 and 400). I have a list of dates in column M, typically no more than 8 dates. Column H of table, contains dates as well. I want to find the dates that are in both columns (H and M) and whenever they appear, go to the same row in column I and set its value to zero, and the one after it (so if a match was in H100, then I100 and I101 would be zeroed).
issues with code: edited 1) as per feedback.
1) I have, using an if formula (=if(H100=M12,1,0), verified that there is one match, as how the spreadsheet sees it. The macro does not find this match, despite confirmation from the if formula. Cells I100 and I101 have nonzero values, when they should be zeroed.
2) the code runs, but takes about 3 minutes to go through 3 sheets of 180 rows of data. What can be done to make it run faster and more efficiently? It could have up to 30 sheets of data, and 400 rows (extreme example but possible, in this instance im happy to let it run a bit).
3) Assuming my data table before the macro is run, is 100 rows long, starting in row 12, after the macro, column I has nonzero values for 111 rows, and zeroes for the next 389. Is there a way I can prevent it from filling down zeroes, and leaving it blank?
I am using a correlate function afterwards on column I and there huge agreement of 0's with 0's is distorting this significantly. Thanks in advance,
Sub DeleteCells()
Dim ws As Worksheet
Dim cell As Range, search_cell As Range
Dim i As Long
Dim h As Long
Application.ScreenUpdating = False
For Each ws In ThisWorkbook.Worksheets
If Not ws.Name = "Cover" Then
For Each cell In ws.Range("H12:H500")
On Error Resume Next
h = ws.Range("G" & Rows.Count).End(xlUp).Row
i = ws.Range("L" & Rows.Count).End(xlUp).Row
Set search_cell = ws.Range("M12:M" & h).Find(what:=cell.Value, LookIn:=xlValues, lookat:=xlWhole)
On Error GoTo 0
If Not search_cell Is Nothing Then
ws.Range("I" & cell.Row).Value = 0
ws.Range("I" & cell.Row + 1).Value = 0
Set search_cell = Nothing
End If
Next cell
End If
Next ws
Application.ScreenUpdating = True
Set ws = Nothing: Set cell = Nothing: Set search_cell = Nothing
End Sub
EDIT: TESTED CODE, will work for 0, 1 row of data in H/M column starting from row 12?
EDIT: Updated the cell to handle case with 1 line of data, untested :|
I will give my solution first, this one should be much faster because it read the cells into memory first
Please comment if it doesn't work or you have further question
Sub DeleteCells()
Dim ws As Worksheet
Dim i As Long
Dim h As Long
Dim MColumn As Variant ' for convinence
Dim HColumn As Variant
Dim IColumn As Variant
Application.ScreenUpdating = False
For Each ws In ThisWorkbook.Worksheets
If Not ws.Name = "Cover" Then 'matching the target sheet
' matching the rows where column M's date matches column H's date
'starting row num is 12
With ws ' for simplifying the code
h = .Range("H" & .Rows.count).End(xlUp).Row
If h = 12 Then ' CASE for 1 row only
If Range("H12").Value = Range("M12").Value Then
Range("I12:I13").Value = ""
End If
ElseIf h < 12 Then
' do nothing
Else
ReDim HColumn(1 To h - 11, 1 To 1)
ReDim MColumn(1 To h - 11, 1 To 1)
ReDim IColumn(1 To h - 10, 1 To 1)
' copying the data from worksheet into 2D arrays
HColumn = .Range("H12:H" & h).Value
MColumn = .Range("M12:M" & h).Value
IColumn = .Range("I12:I" & h + 1).Value
For i = LBound(HColumn, 1) To UBound(HColumn, 1)
If Not IsEmpty(HColumn(i, 1)) And Not IsEmpty(MColumn(i, 1)) Then
If HColumn(i, 1) = MColumn(i, 1) Then
IColumn(i, 1) = ""
IColumn(i + 1, 1) = ""
End If
End If
Next i
'assigning back to worksheet cells
.Range("H12:H" & h).Value = HColumn
.Range("M12:M" & h).Value = MColumn
.Range("I12:I" & h + 1).Value = IColumn
End If
End With
End If
Next ws
Application.ScreenUpdating = True
End Sub