I'm currently trying to create a total, min, max, and average table at the bottom of the sheet. I would also like the "table" to start two cells below the last populated cell.
I am pulling in varying amounts of data which could be a single day, or as many as 100.
Sub max()
Dim N As Long
N = Cells(Rows.COUNT, "B").End(xlUp).Row
'Cells(N + 1, "B").Formula = "=MAX(B$13:B$44" & N & ")" <-COMMENTED OUT / THIS WORKS
Cells(N + 1, "B").Formula = "=IF(COUNT(B$13:B$44)=0,"",MAX(B$13:B$44))" & N & ")"
End Sub
This is what I have so far. I'm getting a 1004 error, and realize I am not calling the variable correctly. I will also need to do this across about 200 columns. Where am I going wrong?
EDIT: Update for non-contiguous tables.
This assumes you don't have anything below or to the right of the table on the worksheet and that your table starts at B13 (headers would be row 12):
Option Explicit
Public Sub BuildStatsTable()
Dim lngMaxRow As Long
Dim lngMaxCol As Long
Dim lngCol As Long
Dim strRng As String
Dim rngLastUsed As Range
Set rngLastUsed = GetLastRange(Cells(13, 2))
lngMaxCol = rngLastUsed.Column
lngMaxRow = rngLastUsed.Row
For lngCol = 2 To lngMaxCol
strRng = "R13C" & lngCol & ":R" & lngMaxRow & "C" & lngCol
Cells(lngMaxRow + 2, lngCol).FormulaR1C1 = "=IF(COUNT(" & strRng & ")=0,"""",SUM(" & strRng & "))"
Cells(lngMaxRow + 3, lngCol).FormulaR1C1 = "=IF(COUNT(" & strRng & ")=0,"""",MIN(" & strRng & "))"
Cells(lngMaxRow + 4, lngCol).FormulaR1C1 = "=IF(COUNT(" & strRng & ")=0,"""",MAX(" & strRng & "))"
Cells(lngMaxRow + 5, lngCol).FormulaR1C1 = "=IF(COUNT(" & strRng & ")=0,"""",AVERAGE(" & strRng & "))"
Next lngCol
End Sub
Private Function GetLastRange(rngTopLeft As Range) As Range
Dim rngUsed As Range
Dim lngMaxRow As Long
Dim lngMaxCol As Long
Set rngUsed = Range(rngTopLeft, rngTopLeft.SpecialCells(xlCellTypeLastCell))
lngMaxRow = rngUsed.Find(What:="*", _
After:=rngUsed.Cells(1), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
lngMaxCol = rngUsed.Find(What:="*", _
After:=rngUsed.Cells(1), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
Set GetLastRange = Cells(lngMaxRow, lngMaxCol)
End Function
When trying to use VBA to create a formula, and in that formula you want to use quotes, you have to "double up":
Cells(N + 1, "B").Formula = "=IF(COUNT(B$13:B$44)=0,"""",MAX(B$13:B$44))" & N & ")"
You can use Chr(34) to append it to the formula.
Cells(N + 1, "B").Formula = "=IF(COUNT(B$13:B$44)=0,"& Chr(34) & Chr(34) &",MAX(B$13:B$44))" & N & ")"
Related
I wrote a code that checks whether the entered data is numeric with the isNumeric function. Now i want to specify and check whether it is an Integer. As far as i know, there is no function like isInteger. How can I check the datatype?
I posted a snippet of the code below, I hope it makes sense like this. If not please let me know.
Thank you for your help!
Sub CheckColumnsHardwareDefinition()
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Hardware Definition")
Dim Target As Range
Dim Target2 As Range
Dim lr As Long
Dim lr2 As Long
Dim DblLengthMin As Double
Dim DblLengthMax As Double
Dim DblWeightMin As Double
Dim DblWeightMax As Double
Dim dynamicArray1() As String
Dim dynamicArray2() As String
Dim f1 As Integer
Dim f2 As Integer
f1 = 0
f2 = 0
DblLengthMax = 20000
DblLengthMin = 5
DblWeightMin = 0.0001
DblWeightMax = 10000
lr3 = Application.WorksheetFunction.Max( _
ws.Range("A" & ws.Rows.Count).End(xlUp).Row, _
ws.Range("B" & ws.Rows.Count).End(xlUp).Row, _
ws.Range("C" & ws.Rows.Count).End(xlUp).Row, _
ws.Range("D" & ws.Rows.Count).End(xlUp).Row, _
ws.Range("E" & ws.Rows.Count).End(xlUp).Row, _
ws.Range("F" & ws.Rows.Count).End(xlUp).Row)
For Each Target3 In Range("A2:F" & lr3)
If IsEmpty(Target3) Then
Target3.Interior.ColorIndex = 8
End If
Next Target3
lr = Application.WorksheetFunction.Max( _
ws.Range("C" & ws.Rows.Count).End(xlUp).Row, _
ws.Range("D" & ws.Rows.Count).End(xlUp).Row, _
ws.Range("E" & ws.Rows.Count).End(xlUp).Row)
For Each Target In Range("C2:E" & lr)
If **Not IsNumeric(Target)** Then
f1 = f1 + 1
Target.Interior.ColorIndex = 3
ReDim Preserve dynamicArray1(0 To f1)
dynamicArray1(f1) = "Row " & Target.Row & " Column " & Target.Column & " wrong
entry: " & Target.Value
End If
If **IsNumeric(Target)** And Target.Value > DblLengthMax Or Target.Value <
DblLengthMin
Then
f2 = f2 + 1
Target.Interior.ColorIndex = 46
ReDim Preserve dynamicArray2(0 To f2)
dynamicArray2(f2) = "Row " & Target.Row & " Column " & Target.Column & " wrong
entry: " & Target.Value
End If
Next Target
Inhalt1 = Join(dynamicArray1, vbCrLf)
MsgBox ("Wrong datatype! " & vbCrLf & vbCrLf & f1 & " Datatype Errors (marked
red)" & vbCrLf & "Only numbers can be entered. Check again" & vbCrLf & Inhalt1)
Inhalt2 = Join(dynamicArray2, vbCrLf)
MsgBox ("Entries out of range!" & vbCrLf & vbCrLf & f2 & " Range errors (marked
orange)" & vbCrLf & "The value is out of range. Check for unit [mm] " & vbCrLf &
Inhalt2)
End Sub
Let's take advantage of the "internal" casting of VBA
Function isInteger(val As Variant) As Boolean
Dim i As Integer
On Error GoTo EH
i = CInt(val)
If i = val Then ' check if it was cut or not
isInteger = True
Else
isInteger = False
End If
Exit Function
EH:
isInteger = False
End Function
As i was declared as integer i=val will cause an overflow and therefore the result is FALSE for 33000. If you do not want that you have to declare i as long and use CLng()
A short version would look like that
Function isInteger(val As Variant) As Boolean
On Error GoTo EH
isInteger = (val = CInt(val))
Exit Function
EH:
End Function
I have a workbook and macro to calculate sum from multiple worksheets and put it to the master sheet. Below is my current macro which works fine. But I need to add one more additional condition to SUM. I think this can be done by using sumif. I have attached my workbook below explaining about my current outcome and expected outcome.
Sub GetSums()
Dim lngCol As Long, wsName As Range
With Sheets("Master")
If .[C3] <> "" Then .Range("C3", .[B3].End(2)) = ""
For Each wsName In .Range("C2", .[B2].End(2))
lngCol = Sheets(wsName.Value).Rows(1).Find("My Text").Column
wsName.Offset(1).Value = _
Evaluate("Sum('" & wsName.Value & "'!" & Cells(3, lngCol + 1).Address & ":" & _
Sheets(wsName.Value).Cells(Rows.Count, lngCol + 1).End(3).Address & ")")
Next wsName
End With
End Sub
Master Sheet
Sheet1
Sheet2
This is how it would look using Sumifs:
Sub GetSums()
Dim lngCol As Long, wsName As Range
With Sheets("Master")
If .[C3] <> "" Then .Range("C3", .[B3].End(2)) = ""
For Each wsName In .Range("C2", .[B2].End(2))
lngCol = Sheets(wsName.Value).Rows(1).Find("My Text").Column
wsName.Offset(1).Value = _
Evaluate("Sumifs('" & wsName.Value & "'!" & Cells(3, lngCol + 1).Address & ":" & _
Sheets(wsName.Value).Cells(Rows.Count, lngCol + 1).End(3).Address & ",'" & _
wsName.Value & "'!" & Cells(3, 2).Address & ":" & _
Sheets(wsName.Value).Cells(Rows.Count, 2).End(3).Address & "," & _
"""ABC"")")
Next wsName
End With
End Sub
BTW I would normally use End(xlToRight) and End(xlUp) rather than End(2) and End(3) ...
I aim to select the rows corresponding to criteria in inputboxes, copy it, and paste it to another worksheet.
The code works but I need to fill all the inputboxes to copy paste the desired rows.
I would like if I do not fill one inputbox, still return all the rows matching the other criteria (example: if just fill the "Issue" InputBox it returns the rows with the matching issue date).
Sub filter()
Dim Bookrunner As String
Dim Bond_Type As Variant
Dim Currency_st As String
Dim Year_Issue As Integer
Bond_Type = InputBox("Choose a Bond Type", "Bond Type")
Currency_st = InputBox("Choose a Currency", "Currency")
Year_Issue = InputBox("Chosse the Year of Issuance", "Issue")
Bookrunner = InputBox("Choose a Bookrunner", "Bookrunner")
Dim copyFrom As Range
Dim i As Long
With Feuil1
For i = 2 To 54
If .Range("B" & i) = Bond_Type And _
.Range("K" & i) = Currency_st And _
.Range("D" & i).Value = Year_Issue And _
(.Range("R" & i) = Bookrunner Or .Range("S" & i) = Bookrunner Or _
.Range("T" & i) = Bookrunner Or .Range("U" & i) = Bookrunner Or _
.Range("V" & i) = Bookrunner Or .Range("w" & i) = Bookrunner) Then
If copyFrom Is Nothing Then
Set copyFrom = .Range("B" & i)
Else
Set copyFrom = Union(.Range("B" & i), copyFrom)
End If
End If
Next
End With
If Not copyFrom Is Nothing Then copyFrom.EntireRow.Copy Destination:=Sheets("Feuil2").Range("A2")
End Sub
I have some code that copies data from one tab and pastes it into another tab then flips the numerical sign on an entire column. Example, -1 in original tab turns to 1 while 1 in original tab turns to -1.
For some reason, if the number in the original tab is a negative, it will not turn positive. If the number in the original tab is a positive, it will turn negative just fine. Any ideas of what might be causing this?
The last 3 lines of code is what ultimately flips the signs but I pasted my entire sub in case there's something elsewhere causing the issue. Thank you in advance!
Sub prep()
Dim c As Range
Dim IRow As Long, lastrow As Long
Dim rSource As Range
Dim wsI As Worksheet, wsO As Worksheet
Dim d As Range
Dim dSource As Range
Dim LR As Long
On Error GoTo Whoa
Set wsI = ThisWorkbook.Sheets("Ben")
Set wsO = ThisWorkbook.Sheets("Upload")
Application.ScreenUpdating = False
wsO.Range("P14", "AB10000").ClearContents
endrow = wsO.Cells(Rows.Count, "T").End(xlUp).Row + 1
With wsI
If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
lastrow = .Columns("O:R").Find(What:="*", _
After:=.Range("O1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
Else
lastrow = 1
End If
Set rSource = .Range("R1:R" & lastrow)
For Each c In rSource
Debug.Print c.Value
If IsNumeric(c.Value) Then
If c.Value > 0 Then
wsO.Cells(14 + IRow, 20).Resize(1, 4).Value = _
.Range("O" & c.Row & ":R" & c.Row).Value
wsO.Cells(14 + IRow, 25).Value = "XXXXXX" & .Range("J" & c.Row).Value
wsO.Cells(14 + IRow, 28).Value = .Range("N" & c.Row).Value
wsO.Cells(14 + IRow, 16).Value = "470"
wsO.Cells(14 + IRow, 17).Value = "I"
wsO.Cells(14 + IRow, 18).Value = "80"
wsO.Cells(14 + IRow, 19).Value = "A"
IRow = IRow + 1
End If
End If
Next
End With
For Each r In Range("W14", Range("W" & Rows.Count).End(xlUp))
r.Value = -r.Value
Next r
The file I work on contains about 80,000 rows
I need to perform some basic checks and copy the results to the new sheet.
The whole thing takes about 8 minutes and I think its too long, is there any faster way?
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
lastCell = checkbook.UsedRange.Rows.Count
ReDim dataArray(2 To lastCell, 1 To 4)
For i = 2 To lastCell
dataArray(i, 1) = checkbook.Range(streetAddress & i).Value
dataArray(i, 2) = checkbook.Range(cityAddress & i).Value
dataArray(i, 3) = checkbook.Range(stateAddress & i).Value
dataArray(i, 4) = checkbook.Range(postCodeAddress & i).Value
Next I
For i = 2 To lastCell
If dataArray(i, 1) = "" Then
results.Range("A" & results.UsedRange.Rows.Count + 1 & ":" & lastCol & results.UsedRange.Rows.Count + 1).Value = checkbook.Range("A" & i & ":" & lastCol & i).Value
results.Range(commentAddress & results.UsedRange.Rows.Count).Value = "BLANK Street"
End If
If dataArray(i, 2) = "" Then
results.Range("A" & results.UsedRange.Rows.Count + 1 & ":" & lastCol & results.UsedRange.Rows.Count + 1).Value = checkbook.Range("A" & i & ":" & lastCol & i).Value
results.Range(commentAddress & results.UsedRange.Rows.Count).Value = "BLANK City"
End If
If dataArray(i, 3) = "" Then
results.Range("A" & results.UsedRange.Rows.Count + 1 & ":" & lastCol & results.UsedRange.Rows.Count + 1).Value = checkbook.Range("A" & i & ":" & lastCol & i).Value
results.Range(commentAddress & results.UsedRange.Rows.Count).Value = "BLANK State"
End If
If dataArray(i, 4) = "" Then
results.Range("A" & results.UsedRange.Rows.Count + 1 & ":" & lastCol & results.UsedRange.Rows.Count + 1).Value = checkbook.Range("A" & i & ":" & lastCol & i).Value
results.Range(commentAddress & results.UsedRange.Rows.Count).Value = "BLANK PostCode"
End If
Next i
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
I feel your pain, I had a sheet like that as well. Working cell by cell will be slow.
Try:
1) Can you try copy the whole Sheet not cell by cell so you have a backup before processing your blanks.
Some of my old code that you can use to modify, copy whole range in one go and put values in a brand new sheet:
Dim s1 As Worksheet
Dim s2 As Worksheet
Set s1 = ThisWorkbook.Sheets(strSourceSheet)
' What is range of source data
lastrow = s1.UsedRange.Rows.Count
lastcol = s1.UsedRange.Columns.Count
' copy across
s1.Range(s1.Cells(1, 1), s1.Cells(lastrow, lastcol)).Copy
' Create new empty worksheet for holding values
Set s2 = Worksheets.Add
s2.Range("A1").PasteSpecial Paste:=xlPasteValuesAndNumberFormats, SkipBlanks:=True
Application.CutCopyMode = False
' You can rename this s2 sheet
2) Then try SEARCH for your blank cells in each column and do a REPLACE. (Use Macro recorder to help get the syntax).
Some sample code below, you will need to clean this up by setting the range instead of using a select on whole column (which will add to blanks below your last row).
' go through each of your columns. Did street example here
Columns("A:A").Select
Selection.Find(What:="", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False).Activate
ActiveCell.Replace What:="", Replacement:="BLANK street", LookAt:=xlWhole _
, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Hope this helps. You seem to know how to code, but if you are stuck then let me know.
I found an answer to the problem
instead of
results.Range(commentAddress & results.UsedRange.Rows.Count)
define for e.g. j and iterate it everytime you add new value to the sheet so
results.Range("A" & k & ":" & lastCol & k ).Value = checkbook.Range("A" & i & ":" & lastCol & i).Value
results.Range(commentAddress & k).Value = "BLANK Street"
k = k + 1
from 8 mins to 5 seconds :)
As per my Knowledge, a Sheet to sheet Traverse is always a time taking process.
i would suggest to use an array to save the details of check and then use them while assigning the values.
results.Range("A" & results.UsedRange.Rows.Count + 1 & ":" & lastCol & results.UsedRange.Rows.Count + 1).Value = array(Value)
The other recommendation is to identify the blank cells during the array assignment only and store the locations in the separate array. so directly you can iterate through only blank values instead of going through all you 80,000