Untitled
unknown
plain_text
6 days ago
29 kB
2
Indexable
Sub ProcessOutlookAndCSV() DownloadAttachmentFromOutlook CreateExcelAndProcessCSV AddAfterWorksheet ProcessModelWorksheet ProcessPortfolioSheets ProcessPortfolioSheets2 ApplyCompareSheetFormulas ProcessCalcSheet End Sub Sub DownloadAttachmentFromOutlook() Dim OutlookApp As Object Dim OutlookNamespace As Object Dim OutlookFolder As Object Dim OutlookMailItem As Object Dim Attachment As Object Dim SearchSubject As String Dim filePath As String Dim FileDate As String Dim SaveFolderPath As String Dim LatestMail As Object Dim MailDate As Date Dim MailHasAttachment As Boolean ' Initialize Outlook application and namespace Set OutlookApp = CreateObject("Outlook.Application") Set OutlookNamespace = OutlookApp.GetNamespace("MAPI") 'Select Inbox folder Set OutlookFolder = OutlookNamespace.Folders("reet.agrawal@nomura.com").Folders("DPM").Folders("JAC Model") ' 6 refers to olFolderInbox ' Set the subject line to search for SearchSubject = "Recommendation for 0900450/IWMJAC" ' Define the file path for saving the attachment filePath = "\\asiapac.nom\data\MUM\IWM\India_IWM_IPAS\Reet\JAC Rebal Code\" ' Modify this with your base file path ' Get today's date in YYYYMMDD format FileDate = Format(Date, "YYYYMMDD") ' Create a folder path with today's date SaveFolderPath = filePath & FileDate & "\" If Dir(SaveFolderPath, vbDirectory) = "" Then MkDir SaveFolderPath End If ' Loop through mails in Inbox to find the latest mail with an attachment MailDate = #1/1/1900# ' Initialize with a very old date MailHasAttachment = False For Each OutlookMailItem In OutlookFolder.Items ' Check if the subject ends with "Nomura All Weather Model Portfolio for IWM DPM" If Right(OutlookMailItem.Subject, Len(SearchSubject)) = SearchSubject Then ' Check if the email is more recent and has attachments If OutlookMailItem.ReceivedTime > MailDate And OutlookMailItem.Attachments.Count > 0 Then MailDate = OutlookMailItem.ReceivedTime Set LatestMail = OutlookMailItem MailHasAttachment = True End If End If Next OutlookMailItem ' If a mail with attachments is found, download them If MailHasAttachment Then For Each Attachment In LatestMail.Attachments ' Save the attachment to the folder Attachment.SaveAsFile SaveFolderPath & Attachment.FileName Next Attachment MsgBox "Attachment downloaded to: " & SaveFolderPath Else MsgBox "No email found with the subject and attachments: " & SearchSubject End If ' Cleanup Set OutlookMailItem = Nothing Set OutlookFolder = Nothing Set OutlookNamespace = Nothing Set OutlookApp = Nothing End Sub Sub CreateExcelAndProcessCSV() Dim filePath As String Dim FileDate As String Dim SaveFolderPath As String Dim LatestCSV As String Dim CSVPath As String Dim NewExcel As Workbook Dim CSVWorkbook As Workbook Dim CSVWorksheet As Worksheet Dim TargetWorksheet As Worksheet Dim FilterRange As Range Dim ColumnsToCopy As Variant Dim Column As Variant Dim CopyRow As Long Dim i As Integer ' Define the base file path for saving the attachment filePath = "\\asiapac.nom\data\MUM\IWM\India_IWM_IPAS\Reet\JAC Rebal Code\" ' Modify this with your base file path CSVPath = "\\asiapac.nom\data\SIN\WMD\Apps\Avaloq\IA_PROD\MIS\" ' Specify your CSV folder path here ' Get today's date in YYYYMMDD format FileDate = Format(Date, "YYYYMMDD") ' Create a folder path with today's date SaveFolderPath = filePath & FileDate & "\" If Dir(SaveFolderPath, vbDirectory) = "" Then MkDir SaveFolderPath End If ' Find the latest CSV file in the specified path LatestCSV = GetLatestFile(CSVPath, "Position_*.csv") If LatestCSV = "" Then MsgBox "No CSV file found in the specified path.", vbCritical Exit Sub End If ' Copy the latest CSV file to the new folder FileCopy CSVPath & LatestCSV, SaveFolderPath & LatestCSV ' Create a new Excel file named JAC_Rebal_{date} Set NewExcel = Application.Workbooks.Add NewExcel.SaveAs SaveFolderPath & "JAC_Rebal_" & FileDate & ".xlsx" ' Open the copied CSV file Set CSVWorkbook = Workbooks.Open(SaveFolderPath & LatestCSV) Set CSVWorksheet = CSVWorkbook.Sheets(1) ' Define columns to copy ColumnsToCopy = Array(10, 22, 17, 15, 7, 20, 12, 16) ' Columns I, V, Q, O, G, T ' Process for both portfolios For i = 1 To 2 ' Create a new sheet for each portfolio Set TargetWorksheet = NewExcel.Sheets.Add TargetWorksheet.Name = "Portfolio " & i ' Apply filter based on portfolio Set FilterRange = CSVWorksheet.UsedRange If i = 1 Then FilterRange.AutoFilter Field:=2, Criteria1:="23138026" Else FilterRange.AutoFilter Field:=2, Criteria1:="23085680" End If ' Copy specified columns CopyRow = 1 For Each Column In ColumnsToCopy ' Copy filtered data from each column On Error Resume Next CSVWorksheet.Columns(Column).SpecialCells(xlCellTypeVisible).Copy TargetWorksheet.Cells(1, CopyRow).PasteSpecial xlPasteValues On Error GoTo 0 CopyRow = CopyRow + 1 Next Column ' Clear filters CSVWorksheet.AutoFilterMode = False Next i ' Delete the default Sheet1 Application.DisplayAlerts = False NewExcel.Sheets("Sheet1").Delete Application.DisplayAlerts = True ' Cleanup CSVWorkbook.Close False NewExcel.Save Application.CutCopyMode = False MsgBox "Data processed and saved to: " & NewExcel.FullName Set CSVWorkbook = Nothing Set NewExcel = Nothing End Sub Function GetLatestFile(FolderPath As String, FilePattern As String) As String Dim FileName As String Dim LatestFile As String Dim LatestDate As Date Dim FileDate As Date FileName = Dir(FolderPath & FilePattern) Do While FileName <> "" FileDate = FileDateFromName(FileName) If FileDate > LatestDate Then LatestDate = FileDate LatestFile = FileName End If FileName = Dir Loop GetLatestFile = LatestFile End Function Function FileDateFromName(FileName As String) As Date Dim DatePart As String On Error Resume Next DatePart = Mid(FileName, InStr(FileName, "_") + 1, 8) FileDateFromName = DateSerial(Left(DatePart, 4), Mid(DatePart, 5, 2), Right(DatePart, 2)) End Function Sub AddAfterWorksheet() Dim SearchFolderPath As String Dim SearchFile As String Dim TargetFilePath As String Dim FoundFile As String Dim SourceWorkbook As Workbook Dim TargetWorkbook As Workbook Dim SourceWorksheet As Worksheet Dim CopiedWorksheet As Worksheet ' Define the folder path based on today's date SearchFolderPath = "\\asiapac.nom\data\MUM\IWM\India_IWM_IPAS\Reet\JAC Rebal Code\" & Format(Date, "YYYYMMDD") & "\" ' Search for a file containing "IWM JAC" SearchFile = Dir(SearchFolderPath & "*IWMJAC*.xls*") ' Matches .xls or .xlsx/.xlsm files If SearchFile = "" Then MsgBox "No file containing 'IWM JAC' found in the folder.", vbCritical Exit Sub End If FoundFile = SearchFolderPath & SearchFile ' Open the found file Set SourceWorkbook = Workbooks.Open(FoundFile) ' Check if the worksheet "After" exists On Error Resume Next Set SourceWorksheet = SourceWorkbook.Sheets("After") On Error GoTo 0 If SourceWorksheet Is Nothing Then MsgBox "'After' worksheet not found in the file: " & FoundFile, vbCritical SourceWorkbook.Close False Exit Sub End If ' Open the target JAC Rebal file TargetFilePath = SearchFolderPath & "JAC_Rebal_" & Format(Date, "YYYYMMDD") & ".xlsx" If Dir(TargetFilePath) = "" Then MsgBox "Target JAC Rebal file not found.", vbCritical SourceWorkbook.Close False Exit Sub End If Set TargetWorkbook = Workbooks.Open(TargetFilePath) ' Copy the "After" worksheet to the JAC Rebal file SourceWorksheet.Copy After:=TargetWorkbook.Sheets(TargetWorkbook.Sheets.Count) Set CopiedWorksheet = TargetWorkbook.Sheets(TargetWorkbook.Sheets.Count) CopiedWorksheet.Name = "Model" ' Save and close the workbooks TargetWorkbook.Save SourceWorkbook.Close False TargetWorkbook.Close MsgBox "'After' worksheet copied successfully to JAC Rebal file as 'Model'." End Sub Sub ProcessModelWorksheet() Dim JACRebalPath As String Dim JACWorkbook As Workbook Dim ModelWorksheet As Worksheet ' Define the file path for the JAC_Rebal file JACRebalPath = "\\asiapac.nom\data\MUM\IWM\India_IWM_IPAS\Reet\JAC Rebal Code\" & Format(Date, "YYYYMMDD") & "\JAC_Rebal_" & Format(Date, "YYYYMMDD") & ".xlsx" ' Check if the JAC_Rebal file exists If Dir(JACRebalPath) = "" Then MsgBox "JAC_Rebal file not found. Please run the previous steps first.", vbCritical Exit Sub End If ' Open the JAC_Rebal file Set JACWorkbook = Workbooks.Open(JACRebalPath) ' Check if the "Model" worksheet exists On Error Resume Next Set ModelWorksheet = JACWorkbook.Sheets("Model") On Error GoTo 0 If ModelWorksheet Is Nothing Then MsgBox "'Model' worksheet not found in JAC_Rebal file.", vbCritical JACWorkbook.Close False Exit Sub End If ' Activate the Model worksheet ModelWorksheet.Activate ' 1) Delete row 1 ModelWorksheet.Rows(1).Delete ' 2) Insert 2 columns between column A and B, and clear their content ModelWorksheet.Columns("B:C").Insert Shift:=xlToRight ModelWorksheet.Columns("B:C").ClearContents ' 3) Perform Text to Columns operation on column A With ModelWorksheet.Columns("A") .TextToColumns Destination:=ModelWorksheet.Columns("A"), _ DataType:=xlDelimited, _ TextQualifier:=xlDoubleQuote, _ ConsecutiveDelimiter:=False, _ Tab:=False, _ Semicolon:=False, _ Comma:=False, _ Space:=True, _ Other:=False End With ' Save and close the workbook JACWorkbook.Save JACWorkbook.Close MsgBox "Model worksheet processed successfully in JAC_Rebal file." End Sub Sub ProcessPortfolioSheets() Dim JACRebalPath As String Dim JACWorkbook As Workbook Dim Sheet As Worksheet Dim SheetName As String ' Define the file path for the JAC_Rebal file JACRebalPath = "\\asiapac.nom\data\MUM\IWM\India_IWM_IPAS\Reet\JAC Rebal Code\" & Format(Date, "YYYYMMDD") & "\JAC_Rebal_" & Format(Date, "YYYYMMDD") & ".xlsx" ' Check if the JAC_Rebal file exists If Dir(JACRebalPath) = "" Then MsgBox "JAC_Rebal file not found. Please run the previous steps first.", vbCritical Exit Sub End If ' Open the JAC_Rebal file Set JACWorkbook = Workbooks.Open(JACRebalPath) ' Loop through all sheets with names "Portfolio {i}" For Each Sheet In JACWorkbook.Sheets If Sheet.Name Like "Portfolio *" Then Sheet.Activate ' 1) Insert 1 column between column A and column B, and clear its content Sheet.Columns("B").Insert Shift:=xlToRight Sheet.Columns("B").ClearContents ' 2) Perform Text to Columns operation on column A With Sheet.Columns("A") .TextToColumns Destination:=Sheet.Columns("A"), _ DataType:=xlDelimited, _ TextQualifier:=xlDoubleQuote, _ ConsecutiveDelimiter:=False, _ Tab:=False, _ Semicolon:=False, _ Comma:=False, _ Space:=True, _ Other:=False End With End If Next Sheet ' Save and close the workbook JACWorkbook.Save JACWorkbook.Close MsgBox "Portfolio sheets processed successfully in JAC_Rebal file." End Sub Sub ProcessPortfolioSheets2() Dim JACRebalPath As String Dim JACWorkbook As Workbook Dim Sheet As Worksheet Dim CompareSheet As Worksheet Dim ModelSheet As Worksheet Dim LastRow As Long Dim PortfolioCounter As Integer Dim PasteColumn As String Dim wsName As String ' Define the file path for the JAC_Rebal file JACRebalPath = "\\asiapac.nom\data\MUM\IWM\India_IWM_IPAS\Reet\JAC Rebal Code\" & Format(Date, "YYYYMMDD") & "\JAC_Rebal_" & Format(Date, "YYYYMMDD") & ".xlsx" ' Check if the JAC_Rebal file exists If Dir(JACRebalPath) = "" Then MsgBox "JAC_Rebal file not found. Please run the previous steps first.", vbCritical Exit Sub End If ' Open the JAC_Rebal file Set JACWorkbook = Workbooks.Open(JACRebalPath) ' Ensure there's no existing "Compare" worksheet On Error Resume Next Application.DisplayAlerts = False JACWorkbook.Sheets("Compare").Delete Application.DisplayAlerts = True On Error GoTo 0 ' Create a new "Compare" worksheet Set CompareSheet = JACWorkbook.Sheets.Add CompareSheet.Name = "Compare" CompareSheet.Range("A1").Value = "Model" CompareSheet.Columns("A").AutoFit ' Copy data from the "Model" worksheet On Error Resume Next Set ModelSheet = JACWorkbook.Sheets("Model") On Error GoTo 0 If Not ModelSheet Is Nothing Then LastRow = ModelSheet.Cells(ModelSheet.Rows.Count, "A").End(xlUp).Row ModelSheet.Range("A2:A" & LastRow).Copy Destination:=CompareSheet.Range("A2") CompareSheet.Columns("A").AutoFit Else MsgBox "Model sheet not found in JAC_Rebal file.", vbCritical Exit Sub End If ' Initialize portfolio counter PortfolioCounter = 1 ' Loop through all sheets with names "Portfolio *" For Each Sheet In JACWorkbook.Sheets If Sheet.Name Like "Portfolio *" Then Sheet.Activate wsName = "P" & PortfolioCounter ' Determine paste column (F for P1, H for P2, J for P3, etc.) PasteColumn = Chr(69 + PortfolioCounter * 3) ' Find the last row in column A LastRow = Sheet.Cells(Sheet.Rows.Count, "A").End(xlUp).Row If LastRow > 1 Then ' Apply filter in column H for "Equities" Sheet.Rows(1).AutoFilter Field:=8, Criteria1:="Equities" ' Copy filtered data from column A If Sheet.Range("A2:A" & LastRow).SpecialCells(xlCellTypeVisible).Count > 0 Then Sheet.Range("A2:A" & LastRow).SpecialCells(xlCellTypeVisible).Copy _ Destination:=CompareSheet.Cells(2, PasteColumn) ' Label the portfolio column CompareSheet.Cells(1, PasteColumn).Value = wsName CompareSheet.Columns(PasteColumn).AutoFit End If ' Turn off filter Sheet.AutoFilterMode = False End If ' Increment portfolio counter PortfolioCounter = PortfolioCounter + 1 End If Next Sheet ' Save and close the workbook JACWorkbook.Save JACWorkbook.Close MsgBox "Portfolio sheets processed and data consolidated successfully in the Compare sheet." End Sub Sub ApplyCompareSheetFormulas() Dim JACRebalPath As String Dim JACWorkbook As Workbook Dim CompareSheet As Worksheet Dim LastRowA As Long, LastRowH As Long, LastRowK As Long Dim i As Long ' Define the file path for the JAC_Rebal file JACRebalPath = "\\asiapac.nom\data\MUM\IWM\India_IWM_IPAS\Reet\JAC Rebal Code\" & Format(Date, "YYYYMMDD") & "\JAC_Rebal_" & Format(Date, "YYYYMMDD") & ".xlsx" ' Check if the JAC_Rebal file exists If Dir(JACRebalPath) = "" Then MsgBox "JAC_Rebal file not found. Please run the previous steps first.", vbCritical Exit Sub End If ' Open the JAC_Rebal file Set JACWorkbook = Workbooks.Open(JACRebalPath) ' Ensure "Compare" sheet exists On Error Resume Next Set CompareSheet = JACWorkbook.Sheets("Compare") On Error GoTo 0 If CompareSheet Is Nothing Then MsgBox "Compare sheet not found. Please ensure it exists before running this macro.", vbCritical JACWorkbook.Close SaveChanges:=False Exit Sub End If ' Find the last row for column A LastRowA = CompareSheet.Cells(CompareSheet.Rows.Count, "A").End(xlUp).Row ' Apply VLOOKUP formulas for column B and C based on column A If LastRowA > 1 Then For i = 2 To LastRowA CompareSheet.Cells(i, 2).Formula = "=IFERROR(VLOOKUP(A" & i & ",H:H,1,0),"""")" CompareSheet.Cells(i, 3).Formula = "=IFERROR(VLOOKUP(A" & i & ",K:K,1,0),"""")" Next i End If ' Find the last row for column H LastRowH = CompareSheet.Cells(CompareSheet.Rows.Count, "H").End(xlUp).Row ' Apply VLOOKUP formula for column I based on column H If LastRowH > 1 Then For i = 2 To LastRowH CompareSheet.Cells(i, 9).Formula = "=IFERROR(VLOOKUP(H" & i & ",A:A,1,0),"""")" Next i End If ' Find the last row for column K LastRowK = CompareSheet.Cells(CompareSheet.Rows.Count, "K").End(xlUp).Row ' Apply VLOOKUP formula for column L based on column K If LastRowK > 1 Then For i = 2 To LastRowK CompareSheet.Cells(i, 12).Formula = "=IFERROR(VLOOKUP(K" & i & ",A:A,1,0),"""")" Next i End If ' Save and close the workbook JACWorkbook.Save JACWorkbook.Close MsgBox "Formulas applied successfully in the Compare sheet." End Sub Sub ProcessCalcSheet() Dim JACRebalPath As String Dim JACWorkbook As Workbook Dim CalcSheet As Worksheet Dim ModelSheet As Worksheet Dim PortfolioSheet As Worksheet Dim LastRowModel As Long Dim LastRowCalc As Long Dim PortfolioCounter As Integer Dim PasteColumn As Integer Dim wsName As String Dim i As Long ' Define the file path for the JAC_Rebal file JACRebalPath = "\\asiapac.nom\data\MUM\IWM\India_IWM_IPAS\Reet\JAC Rebal Code\" & Format(Date, "YYYYMMDD") & "\JAC_Rebal_" & Format(Date, "YYYYMMDD") & ".xlsx" ' Check if the JAC_Rebal file exists If Dir(JACRebalPath) = "" Then MsgBox "JAC_Rebal file not found. Please run the previous steps first.", vbCritical Exit Sub End If ' Open the JAC_Rebal file Set JACWorkbook = Workbooks.Open(JACRebalPath) ' Rename Sheet2 to "Calc" if it exists On Error Resume Next Set CalcSheet = JACWorkbook.Sheets("Sheet2") If Not CalcSheet Is Nothing Then CalcSheet.Name = "Calc" Else MsgBox "Sheet2 not found. Please ensure the sheet exists.", vbCritical Exit Sub End If On Error GoTo 0 Set CalcSheet = JACWorkbook.Sheets("Calc") Set ModelSheet = JACWorkbook.Sheets("Model") ' Get ISINs from Model sheet LastRowModel = ModelSheet.Cells(ModelSheet.Rows.Count, "A").End(xlUp).Row ModelSheet.Range("A2:A" & LastRowModel).Copy Destination:=CalcSheet.Range("B3") ' Format B2 With CalcSheet.Range("B2") .Value = "Model" .Interior.Color = RGB(84, 130, 53) .Font.Color = RGB(255, 255, 255) .Font.Bold = True End With ' Format C2 With CalcSheet.Range("C2") .Value = "Model Wt" .Interior.Color = RGB(84, 130, 53) .Font.Color = RGB(255, 255, 255) .Font.Bold = True End With ' Apply formula in C3 onwards LastRowCalc = CalcSheet.Cells(CalcSheet.Rows.Count, "B").End(xlUp).Row For i = 3 To LastRowCalc CalcSheet.Cells(i, 3).Formula = "=IFERROR(VLOOKUP(B" & i & ",'Model'!A:G,7,0),0)" Next i ' Loop for Portfolio sheets PortfolioCounter = 1 PasteColumn = 4 ' Starting at column D For Each PortfolioSheet In JACWorkbook.Sheets If PortfolioSheet.Name Like "Portfolio *" Then wsName = "P" & PortfolioCounter ' Format Portfolio header With CalcSheet.Cells(2, PasteColumn) .Value = wsName If PortfolioCounter = 1 Then .Interior.Color = RGB(192, 0, 0) ElseIf PortfolioCounter = 2 Then .Interior.Color = RGB(31, 78, 120) End If .Font.Color = RGB(255, 255, 255) .Font.Bold = True End With ' Format Change header With CalcSheet.Cells(2, PasteColumn + 1) .Value = "Change in " & wsName If PortfolioCounter = 1 Then .Interior.Color = RGB(192, 0, 0) ElseIf PortfolioCounter = 2 Then .Interior.Color = RGB(31, 78, 120) End If .Font.Color = RGB(255, 255, 255) .Font.Bold = True End With ' Apply formulas For i = 3 To LastRowCalc CalcSheet.Cells(i, PasteColumn).Formula = "=IFERROR(VLOOKUP(B" & i & ",'" & PortfolioSheet.Name & "'!A:C,3,0),0)" CalcSheet.Cells(i, PasteColumn + 1).Formula = "=C" & i & "-" & Chr(64 + PasteColumn) & i Next i ' Update for next portfolio PortfolioCounter = PortfolioCounter + 1 PasteColumn = PasteColumn + 2 ' Move to the next pair of columns End If Next PortfolioSheet ' Save the workbook JACWorkbook.Save JACWorkbook.Close MsgBox "Calc sheet processed successfully." End Sub Sub ProcessFinalSheet() Dim JACRebalPath As String Dim JACWorkbook As Workbook Dim CalcSheet As Worksheet Dim FinalSheet As Worksheet Dim LastRowCalc As Long Dim LastRowFinal As Long Dim LastRowE1 As Long Dim LastRowE2 As Long Dim LastColumnE1 As Long Dim LastColumnE2 As Long Dim i As Long Dim HeaderRow As Long ' Define the file path for the JAC_Rebal file JACRebalPath = "\\asiapac.nom\data\MUM\IWM\India_IWM_IPAS\Reet\JAC Rebal Code\" & Format(Date, "YYYYMMDD") & "\JAC_Rebal_" & Format(Date, "YYYYMMDD") & ".xlsx" ' Check if the JAC_Rebal file exists If Dir(JACRebalPath) = "" Then MsgBox "JAC_Rebal file not found. Please run the previous steps first.", vbCritical Exit Sub End If ' Open the JAC_Rebal file Set JACWorkbook = Workbooks.Open(JACRebalPath) ' Create or clear the "Final" sheet On Error Resume Next Set FinalSheet = JACWorkbook.Sheets("Final") If FinalSheet Is Nothing Then Set FinalSheet = JACWorkbook.Sheets.Add FinalSheet.Name = "Final" Else FinalSheet.Cells.Clear End If On Error GoTo 0 Set CalcSheet = JACWorkbook.Sheets("Calc") HeaderRow = 2 ' Apply filter in Calc sheet, column E for values > 0.2 or < -0.2 LastRowCalc = CalcSheet.Cells(CalcSheet.Rows.Count, "E").End(xlUp).Row CalcSheet.Rows(HeaderRow).AutoFilter Field:=4, Criteria1:=">0.2", Operator:=xlOr, Criteria2:="<-0.2" ' Copy filtered data for Table 1 If CalcSheet.AutoFilterMode Then If CalcSheet.Range("B3:B" & LastRowCalc).SpecialCells(xlCellTypeVisible).Count > 1 Then CalcSheet.Range("B2:E" & LastRowCalc).SpecialCells(xlCellTypeVisible).Copy Destination:=FinalSheet.Range("B2") End If End If CalcSheet.AutoFilter.ShowAllData LastRowE1 = FinalSheet.Cells(FinalSheet.Rows.Count, "B").End(xlUp).Row LastColumnE1 = FinalSheet.Cells(HeaderRow, FinalSheet.Columns.Count).End(xlToLeft).Column ' Insert Action column for Table 1 FinalSheet.Cells(HeaderRow, LastColumnE1 + 1).Value = "Action" For i = HeaderRow + 1 To LastRowE1 If FinalSheet.Cells(i, "E").Value < 0 Then FinalSheet.Cells(i, LastColumnE1 + 1).Value = "Sell" FinalSheet.Cells(i, LastColumnE1 + 1).Interior.Color = RGB(252, 228, 214) ElseIf FinalSheet.Cells(i, "E").Value > 0 Then FinalSheet.Cells(i, LastColumnE1 + 1).Value = "Buy" FinalSheet.Cells(i, LastColumnE1 + 1).Interior.Color = RGB(226, 239, 218) End If Next i ' Apply filter in Calc sheet, column G for values > 0.2 or < -0.2 LastRowCalc = CalcSheet.Cells(CalcSheet.Rows.Count, "G").End(xlUp).Row CalcSheet.Rows(HeaderRow).AutoFilter Field:=6, Criteria1:=">0.2", Operator:=xlOr, Criteria2:="<-0.2" ' Copy filtered data for Table 2 LastRowFinal = FinalSheet.Cells(FinalSheet.Rows.Count, "B").End(xlUp).Row + 4 If CalcSheet.AutoFilterMode Then If CalcSheet.Range("B3:B" & LastRowCalc).SpecialCells(xlCellTypeVisible).Count > 1 Then CalcSheet.Range("B2:C" & LastRowCalc).SpecialCells(xlCellTypeVisible).Copy Destination:=FinalSheet.Range("B" & LastRowFinal) CalcSheet.Range("F2:F" & LastRowCalc).SpecialCells(xlCellTypeVisible).Copy Destination:=FinalSheet.Range("D" & LastRowFinal) CalcSheet.Range("G2:G" & LastRowCalc).SpecialCells(xlCellTypeVisible).Copy Destination:=FinalSheet.Range("E" & LastRowFinal) End If End If LastRowE2 = FinalSheet.Cells(FinalSheet.Rows.Count, "B").End(xlUp).Row LastColumnE2 = FinalSheet.Cells(HeaderRow + 4, FinalSheet.Columns.Count).End(xlToLeft).Column ' Insert Action column for Table 2 FinalSheet.Cells(LastRowFinal, LastColumnE2).Value = "Action" For i = LastRowFinal + 1 To LastRowE2 If FinalSheet.Cells(i, "E").Value < 0 Then FinalSheet.Cells(i, LastColumnE2 + 1).Value = "Sell" FinalSheet.Cells(i, LastColumnE2 + 1).Interior.Color = RGB(252, 228, 214) ElseIf FinalSheet.Cells(i, "E").Value > 0 Then FinalSheet.Cells(i, LastColumnE2 + 1).Value = "Buy" FinalSheet.Cells(i, LastColumnE2 + 1).Interior.Color = RGB(226, 239, 218) End If Next i ' Sum Change column for Table 1 FinalSheet.Cells(LastRowE1 + 1, "E").Value = Application.WorksheetFunction.Sum(FinalSheet.Range("E3:E" & LastRowE1)) ' Sum Change column for Table 2 FinalSheet.Cells(LastRowE2 + 1, "E").Value = Application.WorksheetFunction.Sum(FinalSheet.Range("E" & LastRowFinal + 1 & ":E" & LastRowE2)) ' Add VLOOKUP formula for Table 1 FinalSheet.Cells(HeaderRow, LastColumnE1 + 2).Value = "Price" For i = HeaderRow + 1 To LastRowE1 FinalSheet.Cells(i, LastColumnE1 + 2).Formula = "=VLOOKUP(B" & i & ", 'Portfolio 1'!A:E, 5, 0)" Next i ' Add VLOOKUP formula for Table 2 FinalSheet.Cells(LastRowFinal, LastColumnE2 + 2).Value = "Price" For i = LastRowFinal + 1 To LastRowE2 FinalSheet.Cells(i, LastColumnE2 + 2).Formula = "=VLOOKUP(B" & i & ", 'Portfolio 2'!A:E, 5, 0)" Next i ' Save and close the workbook JACWorkbook.Save JACWorkbook.Close MsgBox "Final sheet processed successfully." End Sub
Editor is loading...
Leave a Comment