Can anyone please help me how to find and collect the information in the invoice database workbook and make a statistic report in the other report workbook without activating the database?
I've excluded the SumData and SumTotals procedures as they are active only in the report workbook and use already collected data in variables and formulas to write the information in the report. There is also a block in the procedure when collecting data where certain supplier and customers combinations are temporarily excluded until Loop 1 because they are reported separately.
Code:
Option Explicit
Dim vCurPeriod As String, CriteriaColumn As String, vCriteriaName As String, ThisRange As String, svFiscalYear As String
Dim RowNums As Integer, UsedRows As Integer, CurRow As Integer, ColumnOffset As Integer, SubItem As String
Dim BeginRow As Integer, N As Integer, M As Integer, i As Integer, b As String
Dim NoDupes As New Collection, Cell As Range, AllCells As Range, Item, Swap1, Swap2
Dim vSup As String, vCus As String, vProd As String, vCtry As String
Dim vQty As Double, vQtyS As Double, vTB As Double, vTBS As Double, XMon As Integer
Dim vPCurr As String, vSCurr As String, XPCurr As Integer, XSCurr As Integer
Dim vPVal As Double, vFVal As Double, vCVal As Double, vSVal As Double
Dim v€PVal As Double, v€FVal As Double, v€CVal As Double, v€SVal As Double, XPVal As Currency, XSVal As Currency
Dim v€PValS As Double, v€FValS As Double, v€CValS As Double, v€SValS As Double
Dim Loops, FirstSum As Boolean, RowUsed1 As Integer, RowUsed2 As Integer, SumRows As Integer
Dim ConsLine1 As Integer, ConsLine2 As Integer
Dim WBData As Workbook, WSData As Worksheet, WBStats As Workbook, WSStats As Worksheet
Public Sub StatistikRapport()
Application.ScreenUpdating = False
svFiscalYear = Range("FiscalYear")
On Error Resume Next
If Workbooks("TraderData" & svFiscalYear & ".xlsm") Is Nothing Then
Workbooks.Open ("D:\Trader\TraderData\TraderData" & svFiscalYear & ".xlsm")
End If
Windows("TraderData" & svFiscalYear & ".xlsm").WindowState = xlMinimized
On Error GoTo Errhandler
Set WBData = Workbooks("TraderData" & svFiscalYear & ".xlsm")
Set WSData = WBData.Worksheets("InvoiceList")
Set WBStats = Workbooks("TraderStats.xlsm")
Set WSStats = WBStats.Worksheets("Statistic Report")
WSStats.Activate
WSStats.Range("StartCell").Offset(2, 0).Select '(RowOffset, ColOffset)
RowUsed1 = 0
RowUsed2 = 0
ConsLine1 = 0
ConsLine2 = 0
FirstSum = True
vCurPeriod = Range("StatPeriod")
vCriteriaName = Range("Criteria")
Select Case vCriteriaName
Case "Supplierr"
SubItem = "Cus"
CriteriaColumn = "D"
ColumnOffset = 2
Case "Customer"
SubItem = "Sup"
CriteriaColumn = "E"
ColumnOffset = 3
Case "Country"
SubItem = "Cus"
CriteriaColumn = "F"
ColumnOffset = 4
Case "Product"
SubItem = "Cus"
CriteriaColumn = "G"
ColumnOffset = 5
End Select
'********************************************** End Define the Criteria ********************************************
'********************************************** Start searching for ITEMS ******************************************
For Loops = 0 To 1
WSData.Activate
WSData.Range("B14", Range("B14").End(xlDown)).Select
RowNums = Application.WorksheetFunction.CountIf(Selection, vCurPeriod)
WSData.Range("B14").Select
Cells.Find(What:=vCurPeriod, After:=Selection, SearchOrder:=xlByColumns, _
SearchDirection:=xlNext).Activate
BeginRow = ActiveCell.Row
ThisRange = CriteriaColumn & BeginRow & ":" & CriteriaColumn & (BeginRow + RowNums - 1)
Set AllCells = Range(ThisRange)
'***************************************** Find and sort all Items ****************************************
Set NoDupes = Nothing
On Error Resume Next
For Each Cell In AllCells
NoDupes.Add Cell.Value, CStr(Cell.Value)
Next Cell
For M = 1 To NoDupes.Count - 1
For N = M + 1 To NoDupes.Count
If NoDupes(M) > NoDupes(N) Then
Swap1 = NoDupes(M)
Swap2 = NoDupes(N)
NoDupes.Add Swap1, before:=N
NoDupes.Add Swap2, before:=M
NoDupes.Remove M + 1
NoDupes.Remove N + 1
End If
Next N
Next M
'********************************************** End all ITEMS found ****************************************
'
'***********************************************Collecting data per ITEM *******************************************
For Each Item In NoDupes
Do While ActiveCell = vCurPeriod Or ActiveCell = Item '*** If it is the right PERIOD......
If ActiveCell.Offset(0, ColumnOffset) = Item Then '*** If it is the right ITEM the create a statistical row
WSData.Activate
CollectData '*** Collecting 1 datarow from InvoiceList
If Loops = 0 Then '*** If it is the first Loop, exclude the 2 combinations
If vSup = "aaaaCZ" And vCus = "xxxxPL" Then '*** of 2 suppliers and 2 customers as they are presented
ConsLine1 = ConsLine1 + 1 '*** separately under Consignment stock
ActiveCell.Offset(1, 0).Activate
ElseIf vSup = "bbbbCZ" And vCus = "yyyyHU" Then
ConsLine2 = ConsLine2 + 1
ActiveCell.Offset(1, 0).Activate
Else
InsertData '*** Writes the datarow in Statistic Report
End If
ElseIf Loops = 1 Then '*** If it is the second Loop, include only the 2 combinations
If vSup = "aaaaCZ" And vCus = "xxxxPL" Then '*** of 2 suppliers and 2 customers and present them
InsertData '*** separately under Consignment stock
ConsLine1 = ConsLine1 - 1
If ConsLine1 = 0 Then
SumData '*** Writes the Item summary in Statistic Report
End If
ElseIf vSup = "bbbbCZ" And vCus = "yyyyHU" Then
InsertData '*** Writes the datarow in Statistic Report
ConsLine2 = ConsLine2 - 1
If ConsLine2 = 0 Then
SumData '*** Writes the Item summary in Statistic Report
End If
Else
ActiveCell.Offset(1, 0).Activate
End If
End If
Else
WSData.Activate
ActiveCell.Offset(1, 0).Activate
End If
Loop
'**************************************** End treating each individual ITEM *********************************
'
'*********************************************** Sum the Itemrows***************************************
If Loops = 1 Then
'* nothing
Else
SumData
End If
'********************************************** End - Sum the Itemrows***********************************
'
'**************************************** Continue to the next within the same period****************************
WSData.Activate
With WSData.Range("B4")
Cells.Find(What:=vCurPeriod, After:=Selection, SearchOrder:=xlByColumns, SearchDirection:=xlNext).Activate
End With
UsedRows = 0
Next Item
WSStats.Activate
If Loops = 0 Then
With ActiveCell
.Value = "Consignment stock"
.Font.Bold = True
.Resize(1, 18).Borders(xlEdgeBottom).LineStyle = xlContinuous
End With
End If
ActiveCell.Offset(1, 0).Select
Next Loops
'************************************************** Summarize Totals***************************************************
SumTotals '*** Writes the Total summary in Statistic Report
Exit Sub
Errhandler:
MsgBox "There is an Error in procedure StatistikRapport!"
Exit Sub
End Sub
Public Sub CollectData()
Application.ScreenUpdating = False
vSup = ActiveCell.Offset(0, 2).Range("A1") 'supplier
vCus = ActiveCell.Offset(0, 3).Range("A1") 'customer
vCtry = ActiveCell.Offset(0, 4).Range("A1") 'country
vProd = ActiveCell.Offset(0, 5).Range("A1") 'product
vQty = ActiveCell.Offset(0, 6).Range("A1") 'quantity
vPCurr = ActiveCell.Offset(0, 7).Range("A1") 'purchase currency
vPVal = ActiveCell.Offset(0, 8).Range("A1") 'purchase value
v€CVal = ActiveCell.Offset(0, 10).Range("A1") 'cost value *** Always in EUR
vTB = ActiveCell.Offset(0, 12).Range("A1") 'margin
vSCurr = ActiveCell.Offset(0, 13).Range("A1") 'sales currency
vSVal = ActiveCell.Offset(0, 14).Range("A1") 'sales value
XMon = Application.WorksheetFunction.Match(Left(vCurPeriod, 3), Range("Snittmånad"), 0) '*** identifying average exchange rates
XPCurr = Application.WorksheetFunction.Match(vPCurr, Range("Snittvaluta"), 0) '*** setting the purchase currency
XSCurr = Application.WorksheetFunction.Match(vSCurr, Range("Snittvaluta"), 0) '*** setting the sales currency
XPVal = Application.WorksheetFunction.Index(Range("Snittkurser"), XPCurr, XMon) '*** setting the purchase exchange rate
XSVal = Application.WorksheetFunction.Index(Range("Snittkurser"), XSCurr, XMon) '*** setting the sales exchange rate
v€PVal = vPVal / XPVal
v€PValS = v€PValS + v€PVal
v€CValS = v€CValS + v€CVal
v€FVal = v€CVal - v€PVal
v€FValS = v€FValS + v€FVal
v€SVal = vSVal / XSVal
v€SValS = v€SValS + v€SVal
vQtyS = vQtyS + vQty
vTBS = vTBS + vTB
End SubI've excluded the SumData and SumTotals procedures as they are active only in the report workbook and use already collected data in variables and formulas to write the information in the report. There is also a block in the procedure when collecting data where certain supplier and customers combinations are temporarily excluded until Loop 1 because they are reported separately.
