I am not able to take the reference from column AB and AC given in sheet ("UPDATER") to sheet("Historical_vol"), can anyone please confirm what am i doing wrong here ?
Sub historical_vol()
Application.ScreenUpdating = True
'This will help to watch the status bar update
Application.Calculation = xlCalculationManual
Dim wb As Workbook, uPd As Worksheet, hV As Worksheet
Dim lr As Long, cl As Range
Set wb = ThisWorkbook
Set uPd = wb.Sheets("UPDATER")
Set hV = wb.Sheets("Historical_vol")
uPd.Activate
uPd.Range("AD4:AG4", Range("AD4").End(xlDown)).Clear
lr = uPd.Cells(Rows.Count, "AB").End(xlUp).Row
i = 0
For i = 4 To lr
hV.Range("A9:B9").Value = uPd.Range("AB" & i & ":AC" & i).Value
hV.Calculate
DoEvents
uPd.Range("AD" & i & ":AG" & i).Value = hV.Range("C9:F9").Value
Application.StatusBar = i - 3 & " / " & lr - 3
'View on status bar number of records completed out of total records (lr-3)
Next i
Application.Calculation = xlCalculationAutomatic
End Sub
UPDATER SHEET
HISTORICAL_VOL SHEET
Try changing the line
For Each cl In uPd.Range("AB4:AC4" & lr)
to
For Each cl In uPd.Range("AB4:AC" & lr).Rows
and the line
cl.Offset(0, 2).Resize(1, 4).Value = hV.Range("C9:F9").Value
to
cl.Offset(0, 2).Resize(1, 3).Value = hV.Range("C9:F9").Value
Related
Im copying data from workbook to another with the code below. I want to copy customer details and the products with values > 0. Currently my macro is copying all the product columns in a row.
Any ideas how to solve this?
Sub copysales()
Dim wb As New Workbook, rowToCopy As Integer
Dim lRow As Integer, nRow As Integer, rowno As Integer, colno As Integer
Set wb = Workbooks("Product.xlsx")
lRow = ThisWorkbook.Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
nRow = wb.Sheets("Sales").Cells(Rows.Count, 1).End(xlUp).Row + 1
rowToCopy = nRow
Application.ScreenUpdating = False
For rowno = 2 To lRow
If (ThisWorkbook.Sheets("Sheet1").Range("Q" & rowno) = "Close (won)" Or ThisWorkbook.Sheets("Sheet1").Range("Q" & rowno) = "Close (part-won)") _
And ThisWorkbook.Sheets("Sheet1").Range("K" & rowno) > 0 And ThisWorkbook.Sheets("Sheet1").Range("T" & rowno) = Date - 1 Then
For colno = 72 To 79
If ThisWorkbook.Sheets("Sheet1").Cells(rowno, colno) <> "" Then
ThisWorkbook.Sheets("Sheet1").Range("K" & rowno).Copy wb.Sheets("Sales").Range("A" & rowToCopy) 'To copy sales person name
ThisWorkbook.Sheets("Sheet1").Range("D" & rowno).Copy wb.Sheets("Sales").Range("B" & rowToCopy) 'To copy customer name
ThisWorkbook.Sheets("Sheet1").Range("E" & rowno).Copy wb.Sheets("Sales").Range("C" & rowToCopy) 'To copy legal number
ThisWorkbook.Sheets("Sheet1").Range("Q" & rowno).Copy wb.Sheets("Sales").Range("F" & rowToCopy) 'To copy status
ThisWorkbook.Sheets("Sheet1").Range("P" & rowno).Copy wb.Sheets("Sales").Range("G" & rowToCopy) 'To copy sales type
ThisWorkbook.Sheets("Sheet1").Cells(1, colno).Copy wb.Sheets("Sales").Range("H" & rowToCopy) 'To copy product name
ThisWorkbook.Sheets("Sheet1").Cells(rowno, colno).Copy
wb.Sheets("Sales").Range("E" & rowToCopy).PasteSpecial xlPasteValues 'To copy product value
rowToCopy = rowToCopy + 1
End If
Next
End If
Next
End With
Application.ScreenUpdating = True
Application.CutCopyMode = False
End Sub
To copy just the cells where product value is > 0, check for that criteria where you currently check that the product value cell has content (ThisWorkbook.Sheets("Sheet1").Cells(rowno, colno) <> "")
Something perhaps like the following. Reformatted the code and made some changes to improve readability.
Option Explicit
Sub copysales()
Dim rowToCopy As Integer
Dim lRow As Integer, nRow As Integer, rowno As Integer, colno As Integer
'Repeatedly calling the lengthy expression 'ThisWorkbook.Sheets("Sheet1")' to reference Sheet1
'makes the code harder to read and can negatively impact speed if there is a large number of rows
Dim wrkSheet1 As Worksheet
Set wrkSheet1 = ThisWorkbook.Sheets("Sheet1")
'Repeatedly calling the lengthy expression 'wb.Sheets("Sales")' to reference the 'Sales' worksheet
'makes the code harder to read and can negatively impact speed if there is a large number of rows
Dim wrkSheetSales As Worksheet
Set wrkSheetSales = Workbooks("Product.xlsx").Sheets("Sales")
lRow = wrkSheet1.Cells(Rows.Count, 1).End(xlUp).Row
nRow = wrkSheetSales.Cells(Rows.Count, 1).End(xlUp).Row + 1
rowToCopy = nRow
Application.ScreenUpdating = False
For rowno = 2 To lRow
If IsRowOfInterest(wrkSheet1, rowno) Then
For colno = 72 To 79
If HasValueOfInterest(wrkSheet1.Cells(rowno, colno)) Then
wrkSheet1.Range("K" & rowno).Copy wrkSheetSales.Range("A" & rowToCopy) 'To copy sales person name
wrkSheet1.Range("D" & rowno).Copy wrkSheetSales.Range("B" & rowToCopy) 'To copy customer name
wrkSheet1.Range("E" & rowno).Copy wrkSheetSales.Range("C" & rowToCopy) 'To copy legal number
wrkSheet1.Range("Q" & rowno).Copy wrkSheetSales.Range("F" & rowToCopy) 'To copy status
wrkSheet1.Range("P" & rowno).Copy wrkSheetSales.Range("G" & rowToCopy) 'To copy sales type
wrkSheet1.Cells(1, colno).Copy wrkSheetSales.Range("H" & rowToCopy) 'To copy product name
wrkSheet1.Cells(rowno, colno).Copy
wrkSheetSales.Range("E" & rowToCopy).PasteSpecial xlPasteValues 'To copy product value
rowToCopy = rowToCopy + 1
End If
Next
End If
Next
Application.ScreenUpdating = True
Application.CutCopyMode = False
End Sub
'This function checks the criteria for copying the data
Private Function HasValueOfInterest(ByVal valueRange As Range) As Boolean
HasValueOfInterest = False
On Error GoTo ErrorExit
'Not sure how the value is formatted and stored in Sheet1 (String or Number).
'The error handling (On Error GoTo ErrorExit) ensures False is returned when CDbl() operates on a cell value that is not a number
HasValueOfInterest = valueRange.Value <> "" And CDbl(valueRange.Value2) > 0#
Exit Function
ErrorExit:
End Function
'Added to improve readability of the 'copysales' subroutine
Private Function IsRowOfInterest(ByVal wrkSheet As Worksheet, ByVal rowno As Integer) As Boolean
IsRowOfInterest = _
(wrkSheet.Range("Q" & rowno) = "Close (won)" _
Or wrkSheet.Range("Q" & rowno) = "Close (part-won)") _
And wrkSheet.Range("K" & rowno) > 0 _
And wrkSheet.Range("T" & rowno) = Date - 1
End Function
I have an Excel workbook that I Archive data. I take data from my main worksheet and Archive them in different worksheet.
This is the Code that I perform to do that but when I run it, it freezes my Laptop and doesnt perform anything :
Sub trasnfer()
Dim i As Long, j As Long, lastrow1 As Long, lastrow2 As Long
Dim SSL As String
Dim Baureihe As String
Dim Produktionsjahr As String
Dim Garantiejahr As String
Dim RateEA1 As String
Dim RateEa2 As String
Application.screenupdating = false
lastrow1 = Sheets("Transponieren").Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To lastrow1
SSL = Sheets("Transponieren").Cells(i, "A").Value
Baureihe = Sheets("Transponieren").Cells(i, "B").Value
Produktionsjahr = Sheets("Transponieren").Cells(i, "C").Value
Garantiejahr = Sheets("Transponieren").Cells(i, "D").Value
RateEA1 = Sheets("Transponieren").Cells(i, "E").Value
Sheets("Absatzmenge").Activate
lastrow2 = Sheets("Absatzmenge").Range("A" & Rows.Count).End(xlUp).Row
For j = 2 To lastrow2
If Sheets("Absatzmenge").Cells(j, "A").Value = Baureihe Then
If Sheets("Absatzmenge").Cells(j, "B").Value = Produktionsjahr Then
'If Sheets("Absatzmange").Cells(j, "C").Value = Produktionsjahr Then
'If Sheets("Absatzmenge").Cells(j, "D").Value = Garantiejahr Then
'If Sheets ("Absatzmenge").Cells(j, "E").Value = RateEA1 then
Sheets("Transponieren").Activate
Sheets("Transponieren").Range(Cells(i, "A").Cells(i, "E")).Copy
Sheets("Absatzmenge").Activate
Sheets("Absatzmenge").Range(Cells(j, "E").Cells(j, "H")).Select
ActiveSheet.Paste
End If
End If
Next j
Application.CutCopyMode = False
Next i
Application.screenupdating = True
Sheets("Transponieren").Activate
Sheets("Transponieren").Range("A1").Select
End Sub
I tried in much powerful pc but it does the same. Thank you.
I've made some efficiency improvements (please refer to the comments for explanations on some of them). The biggest improvements will come from avoiding .Select and deactivating ScreenUpdating. Inside the second For loop you should also consider adding an Exit For, depending on how many matches you are looking for per data point. You also don't need to look for lastrow2 for every i, once should be enough.
Sub trasnfer()
Application.ScreenUpdating = False
Dim i As Long, j As Long, lastrow1 As Long, lastrow2 As Long
Dim SSL As String
Dim Baureihe As String
Dim Produktionsjahr As String
Dim Garantiejahr As String
Dim RateEA1 As String
Dim RateEa2 As String
lastrow1 = Sheets("Transponieren").Range("A" & Rows.Count).End(xlUp).Row
lastrow2 = Sheets("Absatzmenge").Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To lastrow1
SSL = Sheets("Transponieren").Cells(i, "A").Value
Baureihe = Sheets("Transponieren").Cells(i, "B").Value
Produktionsjahr = Sheets("Transponieren").Cells(i, "C").Value
Garantiejahr = Sheets("Transponieren").Cells(i, "D").Value
RateEA1 = Sheets("Transponieren").Cells(i, "E").Value
For j = 2 To lastrow2
If Sheets("Absatzmenge").Cells(j, "A").Value = Baureihe And _
Sheets("Absatzmenge").Cells(j, "B").Value = Produktionsjahr Then
'If Sheets("Absatzmange").Cells(j, "C").Value = Produktionsjahr Then
'If Sheets("Absatzmenge").Cells(j, "D").Value = Garantiejahr Then
'If Sheets ("Absatzmenge").Cells(j, "E").Value = RateEA1 then
Sheets("Transponieren").Range("A" & i & ":E" & i).Copy _
Destination:=Sheets("Absatzmenge").Range("E" & j)
Application.CutCopyMode = False
'If you are only looking for one match per data point you should add "Exit For" here
'to continnue with the next line in the sheet "Transponieren"
End If
Next j
Next i
Sheets("Transponieren").Activate
Sheets("Transponieren").Range("A1").Select
Application.ScreenUpdating = True
End Sub
Because your two worksheets appear to be tabular in structure with columns in first row and data starting in second and you essentially are enriching the rows in second table with information from matching rows of first table, consider SQL to join the two worksheets and export needed columns.
If using Excel for Windows you can connect to the very workbook using the JET/ACE SQL Engine to query across different range/worksheets.
SQL (left joins to keep all rows of target worksheet and retrieve "enriching" columns)
NOTE: Be sure to replace columns with actual first row headers. Below is embedded in VBA.
SELECT t.ColumnA, t.ColumnB, t.ColumnC, t.ColumnD, t.ColumnE
FROM [Absatzmenge$] a
LEFT JOIN [Transponieren$] t
ON t.[ColumnB] = a.[ColumnA] AND t.[ColumnC] = a.[ColumnB]
VBA (no loops, no arrays, no copy/paste, no select/activate)
Sub RunSQL()
On Error GoTo ErrHandle
Dim conn As Object, rst As Object
Dim sql as String
' INITIALIZE ADO OBJECTS
Set conn = CreateObject("ADODB.Connection")
Set rst = CreateObject("ADODB.Recordset")
sql = "SELECT t.ColumnA, t.ColumnB, t.ColumnC, t.ColumnD, t.ColumnE" _
& " FROM [Absatzmenge$] a " _
& " LEFT JOIN [Transponieren$] t " _
& " ON t.[ColumnB] = a.[ColumnA] AND t.[ColumnC] = a.[ColumnB]"
' OPEN RECORDSET
conn.Open "Driver={Microsoft Excel Driver (*.xls, *.xlsx, *.xlsm, *.xlsb)};" _
& "Dbq=" & ThisWorkbook.FullName & ";"
rst.Open, conn
' EXPORT RESULTS STARTING IN E2 CELL
ThisWorkbook.Worksheets("Absatzmenge").Range("E2").CopyFromRecordset rst
' CLOSE AND RELEASE OBJECTS
rst.Close: conn.Close
ExitHandle:
Set rst = Nothing: Set conn = Nothing
Exit Sub
ErrHandle:
MsgBox Err.Number & " - " & Err.Description, vbCritical, "RUNTIME ERROR"
Resume ExitHandle
End Sub
I'm trying to create a macro which copies rows of data after comparing a column value. I previously asked this question but made some progress, and thought it would be less confusing if i posted another question. The column to be compared is "eRequest ID" and it consists of integers and text.
I have two worksheets, both with "eRequest ID" as the first column. The goal here is to copy ANY rows of data that has an "eRequest ID" NOT FOUND in both worksheets. Meaning if this record's "eRequest ID" is only found on one worksheet and not both, the whole row of data has to be copied into a third new worksheet.
I have worked out some codes after browsing through the net, and with the help of the coding experts here. The problem with this codes is that somehow I get a "mismatch" for every row. I tried changing the foundTrue value here and there but it doesn't seem to work. I need it to only copy rows of data with only 1 "eRequest ID" on either worksheet. Greatful for any help and appreciate your effort!
Sub compareAndCopy()
Dim lastRowE As Integer
Dim lastRowF As Integer
Dim lastRowM As Integer
Dim foundTrue As Boolean
Application.ScreenUpdating = False
lastRowE = Sheets("JULY15Release_Master Inventory").Cells(Sheets("JULY15Release_Master Inventory").Rows.Count, "A").End(xlUp).Row
lastRowF = Sheets("JULY15Release_Dev status").Cells(Sheets("JULY15Release_Dev status").Rows.Count, "A").End(xlUp).Row
lastRowM = Sheets("Mismatch").Cells(Sheets("Mismatch").Rows.Count, "A").End(xlUp).Row
For i = 1 To lastRowE
foundTrue = True
For j = 1 To lastRowF
'If Sheets("JULY15Release_Master Inventory").Cells(i, 2).Value = Sheets("JULY15Release_Dev status").Cells(j, 7).Value Then
If Sheets("JULY15Release_Master Inventory").Cells(i, 2).Value <> Sheets("JULY15Release_Dev status").Cells(j, 7).Value Then
foundTrue = False
Exit For
End If
Next j
If foundTrue Then
Sheets("JULY15Release_Dev status").Rows(i).Copy Destination:= _
Sheets("Mismatch").Rows(lastRowM + 1)
lastRowM = lastRowM + 1
End If
Next i
Application.ScreenUpdating = False
End Sub
another one variant
Sub test()
Dim lastRowE&, lastRowF&, lastRowM&, Key As Variant
Dim Cle As Range, Clf As Range
Dim DicInv As Object: Set DicInv = CreateObject("Scripting.Dictionary")
Dim DicDev As Object: Set DicDev = CreateObject("Scripting.Dictionary")
Application.ScreenUpdating = 0
lastRowE = Sheets("JULY15Release_Master Inventory").Cells(Rows.Count, "A").End(xlUp).Row
lastRowF = Sheets("JULY15Release_Dev status").Cells(Rows.Count, "A").End(xlUp).Row
lastRowM = Sheets("Mismatch").Cells(Rows.Count, "A").End(xlUp).Row
'add into dictionary row number from Inventory where cell is matched
For Each Cle In Sheets("JULY15Release_Master Inventory").Range("A1:A" & lastRowE)
If Cle.Value <> "" Then
For Each Clf In Sheets("JULY15Release_Dev status").Range("A1:A" & lastRowF)
If UCase(Cle.Value) = UCase(Clf.Value) Then DicInv.Add Cle.Row, ""
Next Clf
End If
Next Cle
'add into dictionary row number from Dev where cell is matched
For Each Clf In Sheets("JULY15Release_Dev status").Range("A1:A" & lastRowF)
If Clf.Value <> "" Then
For Each Cle In Sheets("JULY15Release_Master Inventory").Range("A1:A" & lastRowE)
If UCase(Clf.Value) = UCase(Cle.Value) Then DicDev.Add Clf.Row, ""
Next Cle
End If
Next Clf
'Get mismatch from Inventory
With Sheets("JULY15Release_Master Inventory")
For Each Cle In .Range("A1:A" & lastRowE)
If Not DicInv.exists(Cle.Row) And Cle.Value <> "" Then
.Rows(Cle.Row).Copy Sheets("Mismatch").Rows(lastRowM)
lastRowM = lastRowM + 1
End If
Next Cle
End With
'Get mismatch from Dev
With Sheets("JULY15Release_Dev status")
For Each Clf In .Range("A1:A" & lastRowF)
If Not DicDev.exists(Clf.Row) And Clf.Value <> "" Then
.Rows(Clf.Row).Copy Sheets("Mismatch").Rows(lastRowM)
lastRowM = lastRowM + 1
End If
Next Clf
End With
Application.ScreenUpdating = 1
End Sub
Sample
JULY15Release_Master Inventory
JULY15Release_Dev status
Output Result
Mismatch
Try this, it should work, TESTED.
Sub test()
Dim lrow1 As Long
Dim lrow2 As Long
Dim i As Long
Dim K As Long
Dim j As Long
Dim p As Variant
Dim wb As Workbook
Set wb = ThisWorkbook
K = 2
lrow1 = wb.Sheets("JULY15Release_Master Inventory").Range("A" & Rows.Count).End(xlUp).Row
lrow2 = wb.Sheets("JULY15Release_Dev status").Range("A" & Rows.Count).End(xlUp).Row
For i = 1 To lrow1
p = Application.Match(wb.Sheets("JULY15Release_Master Inventory").Range("A" & i).Value, wb.Sheets("JULY15Release_Dev status").Range("A1" & ":" & "A" & lrow2), 0)
If IsError(p) Then
wb.Sheets("JULY15Release_Master Inventory").Rows(i).Copy Destination:=Sheets("Mismatch").Rows(K)
K = K + 1
End If
Next
For j = 1 To lrow2
p = Application.Match(wb.Sheets("JULY15Release_Dev status").Range("A" & j).Value, wb.Sheets("JULY15Release_Master Inventory").Range("A1" & ":" & "A" & lrow1), 0)
If IsError(p) Then
wb.Sheets("JULY15Release_Dev status").Rows(j).Copy Destination:=Sheets("Mismatch").Rows(K)
K = K + 1
End If
Next
End Sub
I have 50 .xls files saved on a shared drive by the name of users. Eg: "Rahul Goswami.xls", "Rohit Sharma.xls", etc.
Each Excel file contains 2 worksheets: "Case Tracker" and "Pending Tracker".
In the "Case Tracker" worksheet users put their daily data/ daily production.
I wanted VBA code to pull the entire "Case Tracker" worksheet from all 50 Excel files in one separate Excel workbook, one below the other.
Currently I am copy-pasting the data from the Excel files to the master workbook to "Sheet1".
Can there be something where I put the date and the data will come automatically for that date from all the 50 files?
Column A to J contains the data provided below. This example is given for 1 user.
Date Advisor Userid BP URN Stage Case Type Previous Status Current status Category
10-Apr Rahul Goswami goswami 123456 98765431 1 URN New Pend abc
Sub Beachson()
Dim z As Long, e As Long, d As Long, G As Long, h As Long Dim f As String
d = 2
Cells(1, 1) = "=cell(""filename"")"
Cells(1, 2) = "=left(A1,find(""["",A1)-1)"
Cells(2, 1).Select
f = Dir(Cells(1, 2) & "*.xls")
Do While Len(f) > 0
## Heading ##
ActiveCell.Formula = f
ActiveCell.Offset(1, 0).Select
f = Dir()
Loop
z = Cells(Rows.Count, 1).End(xlUp).Row
For e = 2 To z
If Cells(e, 1) <> ActiveWorkbook.Name Then
Cells(d, 2) = Cells(e, 1)
Cells(1, 4) = "=Counta('" & Cells(1, 2) & "[" & Cells(e, 1) & "]Case Tracker'!I:I)"
For h = 10 To Cells(1, 4)
For G = 1 To 10
Cells(1, 3) = "='" & Cells(1, 2) & "[" & Cells(e, 1) & "]Case Tracker'!" & Chr(G + 64) & h
Cells(d, G + 2) = Cells(1, 3)
Next G
d = d + 1
Next h
End If
d = d + 1
Next e
MsgBox "collating is complete."
End Sub
I would avoid storing information in sheet, then going to VBA, then again to sheet, etc.
As for your problem of not being able to pull data when a file is open, I would suggest creating another instance of Excel.Application and opening files from it in ReadOnly mode.
This is the code which worked for me (the ability to find particular dates is also implemented):
Sub Beachson2()
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
Dim App As Object
Set App = CreateObject("Excel.Application")
Dim wsSource As Worksheet
Dim sFold As String
sFold = ThisWorkbook.Path & "\"
Dim sFile As String
Dim i As Long, j As Long
Dim cell As Range
' Setting date
Dim sInput As String, dInput As Date
sInput = Application.InputBox("Enter A Date")
If IsDate(sInput) Then
dInput = DateValue(sInput)
Else
MsgBox "Invalid date. Exiting..."
Exit Sub
End If
Application.ScreenUpdating = False
' Pulling data
i = 1
sFile = Dir(sFold & "\*.xls")
Do While sFile <> ""
If sFile <> sFold & ThisWorkbook.Name Then
Set wsSource = App.Workbooks.Open(Filename:=sFold & sFile, ReadOnly:=True).Sheets("Case Tracker")
For Each cell In wsSource.Range("A1:A" & wsSource.UsedRange.Rows.Count)
If cell.Value = CStr(dInput) Then
With ws.Cells(Rows.Count, 1).End(xlUp)
If IsEmpty(.Value2) Then
.Value2 = sFile
ElseIf .Value2 <> sFile Then
.Offset(1).Value2 = sFile
Else
'do nothing
End If
End With
If ws.Cells(Rows.Count, 2).End(xlUp).Value2 <> sFile Then
ws.Cells(i, 2).Value2 = sFile
End If
For j = 3 To 12
ws.Cells(i, j).Value = wsSource.Cells(cell.Row, j - 2).Value
Next
i = i + 1
End If
Next
wsSource.Parent.Close
End If
sFile = Dir()
Loop
Application.ScreenUpdating = True
App.Quit
MsgBox "collating is complete."
Set App = Nothing
End Sub
The code is stored in the master file.
Even in the code there is no one specific Date format defined, but I still think it is capable of causing problems. If you find problems regarding date formats, please post your used date format.
I have SUMIF running really really slow. My data has 14,800 Rows and 39 Columns.
I do the following:
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
ActiveSheet.DisplayPageBreaks = False
EDITED TO ADD more potentially relevant code that may be interacting with the SUMIF command
It may be relevant to the speed issue so I'll mention it. I get the user to open a file from wherever they may have stored the report. The file then stays open. Maybe that is a problem. I don't know if it should be some other way.. like I close it but keep the address in mind or something??
FilterType = "Text Files (*.txt),*.txt," & "Comma Separated Files (*.csv),*.csv," & "ASCII Files (*.asc),*.asc," & "All Files (*.*),*.*"
FilterIndex = 4
Title = "File to be Selected"
File_path = Application.GetOpenFilename(FileFilter:=FilterType, FilterIndex:=FilterIndex, Title:=Title)
If File_path = "" Then
MsgBox "No file was selected."
Exit Sub
End If
Set wbSource = Workbooks.Open(File_path)
Original_Name = ActiveWorkbook.Name
If ActiveSheet.AutoFilterMode Then
ActiveSheet.AutoFilterMode = False
End If
Set wb1 = ActiveWorkbook
Set ws1 = wb1.Worksheets("Sheet1")
With ws1
FinalColumn = .Cells(1, .Columns.Count).End(xlToLeft).Column
FinalRow = .Range("B" & .Rows.Count).End(xlUp).Row
For j = 1 To FinalColumn
If .Cells(1, j).Value = "Effec.Date" Then
Effective_Date_Column = j
ElseIf .Cells(1, j).Value = "FolderId" Then
FolderId_column = j
ElseIf .Cells(1, j).Value = "FolderNotional" Then
FolderNotional_column = j
End If
Next j
'range_Total_Folder_Fixed = .Cells(2, Total_Folder_Column).Address & ":" & .Cells(FinalRow, Total_Folder_Column).Address
range_FolderId_Fixed = .Cells(2, FolderId_column).Address & ":" & .Cells(FinalRow, FolderId_column).Address
range_FolderId_Cell = .Cells(2, FolderId_column).Address(RowAbsolute:=False, ColumnAbsolute:=False)
range_FolderNotional_Fixed = .Cells(2, FolderNotional_column).Address & ":" & .Cells(FinalRow, FolderNotional_column).Address
Everything runs in 8-10 seconds until we come to the lie below. Now the total time jumps to a 150 seconds.
.Range(range_Total_Folder_Fixed).Formula = "=SUMIF(" & range_FolderId_Fixed & "," & range_FolderId_Cell & "," & range_FolderNotional_Fixed & ")"
Am I doing something wrong? Is there a better (more efficient) way to write a general formula?
EDIT: Code generated Raw Formula
Some of the excel worksheet functions in my code:
.Range(range_Isnumber).Formula = "=(RIGHT(" & range_TradeId_cell & ",2)<> ""IB"")*1"
.Range(range_Is_IB).Formula = "=(RIGHT(" & range_TradeId_cell & ",2)= ""IB"")*1"
.Range(range_Exceptions).Formula = "=(SUMIF(" & range_FolderId_Fixed & "," & range_FolderId_Cell & "," & range_Isnumber_fixed & ")= COUNTIF(" & range_FolderId_Fixed & "," & range_FolderId_Cell & "))*1+(SUMIF(" & range_FolderId_Fixed & "," & range_FolderId_Cell & "," & range_Is_IB_fixed & ")= COUNTIF(" & range_FolderId_Fixed & "," & range_FolderId_Cell & "))*1 "
.Range("C13").FormulaR1C1 = "=SUM(IF(FREQUENCY(MATCH([SCL_FL_2013_11_30.xlsx]Rest!R2C2:R2321C2,[SCL_FL_2013_11_30.xlsx]Rest!R2C2:R2321C2,0),MATCH([SCL_FL_2013_11_30.xlsx]Rest!R2C2:R2321C2,[SCL_FL_2013_11_30.xlsx]Rest!R2C2:R2321C2,0))>0,1))"
So Stuff like
Range("I2")=SUMIF($H$2:$H$5,H2,$G$2:$G$5)
Where the data could be like
RowG RowH RowI
Alice 1 4
Alice 3 4
Bob 9 17
Bob 8 17
Dan 2 2
EDIT2 : Implementing Sam's solution, I am getting errors:
Set range_FolderId_Fixed = .Range(.Cells(2, FolderId_column), .Cells(FinalRow, FolderId_column))
Set range_FolderId_Cell = .Range(.Cells(2, FolderId_column),.Cells(FinalRow, FolderId_column))
Set range_FolderNotional_Fixed = .Range(.Cells(2, FolderNotional_column), .Cells(FinalRow, FolderNotional_column))
Set range_Total_Folder_Fixed = .Range(.Cells(2, Total_Folder_Column), .Cells(FinalRow, Total_Folder_Column))
.Range(range_Total_Folder_Fixed).Value = SumIf_func(range_FolderId_Fixed, range_FolderId_Cell, range_FolderNotional_Fixed)
I am getting a type application defined or object defined error in the line below.
.Range(range_Total_Folder_Fixed).Value = SumIf_func(range_FolderId_Fixed, range_FolderId_Cell, range_FolderNotional_Fixed)
I have no idea what to do next.
Ok this is what I came up with
Public Function SumIf_func(rng As Range, _
criteria As Range, _
sumRange As Range) As Variant()
Dim rngArr() As Variant
Dim sumArr() As Variant
Dim criteriaArr() As Variant
Dim returnArr() As Variant
Dim temp As Double
rngArr = rng.Value2
sumArr = sumRange.Value2
criteriaArr = criteria.Value2
If UBound(sumArr) <> UBound(rngArr) Then _
Err.Raise 12345, "SumIf_func", "Sum range and check range should be the same size"
If UBound(sumArr, 2) <> 1 Or UBound(rngArr, 2) <> 1 Then _
Err.Raise 12346, "SumIf_func", "Sum range and check range should be a single column"
ReDim returnArr(1 To UBound(criteriaArr), 1 To 1)
For c = LBound(criteriaArr) To UBound(criteriaArr)
returnArr(c, 1) = Application.WorksheetFunction.SumIf(rng, criteriaArr(c, 1), sumRange)
Next c
SumIf_func = returnArr
End Function
This function takes in three ranges:
The range to check
The range where the criteria are
The range where the values to sum are
The range to check and the sum range should both be the same length and only be 1 column across.
The array that is returned will be the same size as the criteria array..
Here is an example of usage:
Public Sub test_SumIf()
Dim ws As Worksheet
Set ws = Sheet1
Dim rng As Range, sumRng As Range, criteria As Range
Set rng = ws.Range("A1:A100")
Set sumRng = ws.Range("B1:B100")
Set criteria = ws.Range("C1:C10")
ws.Range("D1:D10").Value = SumIf_func(rng, criteria, sumRng)
End Sub