Useful vba code snipits

gitch10 · 13-06-2024 9:55am

Sub VerifyAndCreateIDX()
Dim ws As Worksheet
Dim lastRow As Long
Dim postingRange As Range
Dim cell As Range
Dim priorMonthDate As Date
Dim hasPriorMonthPosting As Boolean
Dim userResponse As VbMsgBoxResult
Dim priorMonthRows As String

' Set the worksheet to check
Set ws = ThisWorkbook.Sheets("Sheet1") ' Change "Sheet1" to your sheet name

' Find the last row with data in column A
lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row

' Define the dynamic range to check
Set postingRange = ws.Range("A2:A" & lastRow)

' Calculate the first day of the prior month
priorMonthDate = DateSerial(Year(Date), Month(Date) - 1, 1)

' Initialize flag and prior month rows string
hasPriorMonthPosting = False
priorMonthRows = ""

' Check for postings in the prior month
For Each cell In postingRange
    If IsDate(cell.Value) Then
        If cell.Value >= priorMonthDate And cell.Value < DateSerial(Year(Date), Month(Date), 1) Then
            hasPriorMonthPosting = True
            priorMonthRows = priorMonthRows & "Row " & cell.Row & ": " & cell.Value & vbCrLf
        End If
    End If
Next cell

' Handle the result
If hasPriorMonthPosting Then
    userResponse = MsgBox("Transactions in prior period were found in the following rows:" & vbCrLf & priorMonthRows & _
                          "Please confirm you wish to post them", vbExclamation + vbOKCancel, "Confirm Posting")
    If userResponse = vbCancel Then
        MsgBox "Posting cancelled. IDX not created.", vbInformation, "Cancelled"
        Exit Sub
    Else
        ' Call the IDX creation function
        Call CreateIDX
    End If
Else
    MsgBox "No posting to prior period found", vbInformation, "No Prior Postings"
End If

End Sub

Sub CreateIDX()
' Your code to create the IDX goes here
MsgBox "IDX created successfully.", vbInformation, "Success"
End Sub

gitch10 · 18-06-2024 1:01pm

Sub RemoveRedFill()
Dim ws As Worksheet
Dim cell As Range
Dim rowRange As Range
Dim colorRed As Long

' Set your target worksheet here, e.g., Sheet1
Set ws = ThisWorkbook.Sheets("Sheet1")

' Define the RGB value for the red color you want to remove
colorRed = RGB(255, 0, 0)

' Loop through each row in the worksheet
For Each rowRange In ws.UsedRange.Rows
    ' Check if any cell in the row has the red fill
    For Each cell In rowRange.Cells
        If cell.Interior.Color = colorRed Then
            ' If found, remove the fill color from all cells in the row
            rowRange.Interior.ColorIndex = xlNone
            Exit For
        End If
    Next cell
Next rowRange

End Sub

gitch10 · 21-06-2024 6:02pm

Sub TransferRecords()
Dim wsSource As Worksheet
Dim wsDest As Worksheet
Dim lastRowSource As Long
Dim lastRowDest As Long
Dim i As Long

' Set worksheets
Set wsSource = Worksheets("brokerdata")
Set wsDest = Worksheets("fx_extract")

' Find the last row of the source sheet
lastRowSource = wsSource.Cells(wsSource.Rows.Count, "L").End(xlUp).Row

' Find the last row of the destination sheet
lastRowDest = wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Row + 1

' Loop through each row in the source sheet
For i = 2 To lastRowSource
    ' Check if the cell in column L contains the text "transfer"
    If InStr(1, wsSource.Cells(i, "L").Value, "transfer", vbTextCompare) > 0 Then
        ' Copy the entire row to the next available row in the destination sheet
        wsSource.Rows(i).Copy Destination:=wsDest.Rows(lastRowDest)
        ' Increment the last row of the destination sheet
        lastRowDest = lastRowDest + 1
    End If
Next i

MsgBox "Records have been transferred."

End Sub

gitch10 · 24-06-2024 8:43pm

' JournalEntry Class
Option Explicit

Public DateValue As Variant
Public AnalysisCode As Variant
Public ValueEUR As Variant
Public Notes As Variant
Public AdditionalNotes As Variant

' Initialize the class with data from the row
Public Sub Init(ByVal dateVal As Variant, ByVal analysis As Variant, ByVal value As Variant, ByVal notes As Variant, ByVal additionalNotes As Variant)
DateValue = dateVal
AnalysisCode = analysis
ValueEUR = value
Notes = notes
AdditionalNotes = additionalNotes
End Sub

gitch10 · 24-06-2024 8:43pm

Sub CopyJrnCreditRows()
Dim srcSheet As Worksheet
Dim destSheet As Worksheet
Dim lastRow As Long
Dim i As Long
Dim journalEntries As Collection
Dim je As JournalEntry
Dim destLastRow As Long

' Set the source and destination sheets
Set srcSheet = ThisWorkbook.Sheets("SourceSheetName") ' Change to your source sheet name
Set destSheet = ThisWorkbook.Sheets("DestinationSheetName") ' Change to your destination sheet name

' Find the last row with data in the source sheet
lastRow = srcSheet.Cells(srcSheet.Rows.Count, "C").End(xlUp).Row

' Initialize the collection
Set journalEntries = New Collection

' Loop through each row in the source sheet
For i = 1 To lastRow
    ' Check if column C contains "jrncredit"
    If InStr(1, srcSheet.Cells(i, "C").Value, "jrncredit", vbTextCompare) > 0 Then
        ' Create a new JournalEntry object and initialize it
        Set je = New JournalEntry
        je.Init srcSheet.Cells(i, "O").Value, srcSheet.Cells(i, "P").Value, srcSheet.Cells(i, "Q").Value, srcSheet.Cells(i, "S").Value, srcSheet.Cells(i, "T").Value
        ' Add the JournalEntry object to the collection
        journalEntries.Add je
    End If
Next i

' Find the next empty row in the destination sheet
destLastRow = destSheet.Cells(destSheet.Rows.Count, "A").End(xlUp).Row + 1

' Loop through the collection and write to the destination sheet
For i = 1 To journalEntries.Count
    With journalEntries(i)
        destSheet.Cells(destLastRow, "A").Value = .DateValue
        destSheet.Cells(destLastRow, "B").Value = .AnalysisCode
        destSheet.Cells(destLastRow, "C").Value = .ValueEUR
        destSheet.Cells(destLastRow, "D").Value = .Notes
        destSheet.Cells(destLastRow, "E").Value = .AdditionalNotes
    End With
    destLastRow = destLastRow + 1
Next i

MsgBox "Copy complete!"

End Sub

gitch10 · 24-06-2024 9:32pm

Sub CopyJrnData()
Dim sourceSheet As Worksheet
Dim destSheetCredit As Worksheet
Dim destSheetDebit As Worksheet
Dim lastRow As Long
Dim i As Long
Dim creditRow As Long
Dim debitRow As Long

' Set the worksheets
Set sourceSheet = ThisWorkbook.Sheets("SourceSheet") ' Replace with your source sheet name
Set destSheetCredit = ThisWorkbook.Sheets("CreditSheet") ' Replace with your credit destination sheet name
Set destSheetDebit = ThisWorkbook.Sheets("DebitSheet") ' Replace with your debit destination sheet name

' Initialize the last row in the destination sheets
creditRow = 2 ' Assuming headers in the first row
debitRow = 2 ' Assuming headers in the first row

' Find the last row with data in the source sheet
lastRow = sourceSheet.Cells(sourceSheet.Rows.Count, "C").End(xlUp).Row

' Loop through each row in the source sheet
For i = 1 To lastRow
    If InStr(1, sourceSheet.Cells(i, "C").Value, "jrncredit", vbTextCompare) > 0 Then
        ' Copy to Credit Sheet
        destSheetCredit.Cells(creditRow, "A").Value = sourceSheet.Cells(i, "O").Value
        destSheetCredit.Cells(creditRow, "B").Value = sourceSheet.Cells(i, "P").Value
        destSheetCredit.Cells(creditRow, "C").Value = sourceSheet.Cells(i, "Q").Value
        destSheetCredit.Cells(creditRow, "D").Value = sourceSheet.Cells(i, "S").Value
        destSheetCredit.Cells(creditRow, "E").Value = sourceSheet.Cells(i, "T").Value
        creditRow = creditRow + 1
    ElseIf InStr(1, sourceSheet.Cells(i, "C").Value, "jrndebit", vbTextCompare) > 0 Then
        ' Copy to Debit Sheet
        destSheetDebit.Cells(debitRow, "A").Value = sourceSheet.Cells(i, "O").Value
        destSheetDebit.Cells(debitRow, "B").Value = sourceSheet.Cells(i, "P").Value
        destSheetDebit.Cells(debitRow, "C").Value = sourceSheet.Cells(i, "Q").Value
        destSheetDebit.Cells(debitRow, "D").Value = sourceSheet.Cells(i, "S").Value
        destSheetDebit.Cells(debitRow, "E").Value = sourceSheet.Cells(i, "T").Value
        debitRow = debitRow + 1
    End If
Next i

MsgBox "Data has been copied successfully."

End Sub

gitch10 · 25-06-2024 9:40pm

Sub SendEmails()
Dim OutlookApp As Object
Dim OutlookMail As Object
Dim i As Integer
Dim lastRow As Long
Dim ws As Worksheet
Dim subjectText As String
Dim bodyText As String

' Set your worksheet
Set ws = ThisWorkbook.Sheets("Sheet1") ' Change "Sheet1" to your sheet name

' Get the last row with data in column C
lastRow = ws.Cells(ws.Rows.Count, "C").End(xlUp).Row

' Create Outlook application object
On Error Resume Next
Set OutlookApp = GetObject(class:="Outlook.Application")
If OutlookApp Is Nothing Then
    Set OutlookApp = CreateObject(class:="Outlook.Application")
End If
On Error GoTo 0

' Loop through each row from 2 to lastRow
For i = 2 To lastRow ' Assuming row 1 is the header
    ' Get the subject and body text from the respective columns
    subjectText = ws.Cells(i, 3).Value & " " & ws.Cells(i, 4).Value
    bodyText = "The value in column F is: " & ws.Cells(i, 6).Value & vbCrLf & _
               "This is some other text that you wanted in the email body."
    
    ' Create a new email item
    Set OutlookMail = OutlookApp.CreateItem(0)
    
    ' Set the properties of the email
    With OutlookMail
        .To = "me@iol.ie"
        .Subject = subjectText
        .Body = bodyText
        .Send
    End With
    
    ' Clear the mail object
    Set OutlookMail = Nothing
Next i

' Clear the Outlook application object
Set OutlookApp = Nothing

' Inform the user
MsgBox "Emails have been sent successfully!", vbInformation

End Sub

gitch10 · 28-06-2024 11:05am

Sub CheckColumnC()

Dim ws As Worksheet
Dim lastRow As Long
Dim i As Long
Dim foundOther As Boolean

' Initialize variables
Set ws = ThisWorkbook.Sheets("Sheet1") ' Change "Sheet1" to your sheet name
lastRow = ws.Cells(ws.Rows.Count, "C").End(xlUp).Row
foundOther = False

' Loop through each cell in column C
For i = 1 To lastRow
    If ws.Cells(i, 3).Value <> "EUR" Then
        foundOther = True
        Exit For
    End If
Next i

' Check the result and perform actions
If foundOther Then
    ' Perform action if a value not equal to "EUR" is found
    MsgBox "A value not equal to 'EUR' was found in column C."
    ' Add your code for this condition here
Else
    ' Perform action if all values are "EUR"
    MsgBox "All values in column C are 'EUR'."
    ' Add your code for this condition here
End If

End Sub

gitch10 · 02-07-2024 11:39am

@echo off
setlocal enabledelayedexpansion

REM Output file name
set output_file=merged_output.csv

REM Check if output file already exists and delete it if it does
if exist %output_file% del %output_file%

REM Initialize a flag to indicate the first file
set first_file=1

REM Loop through all CSV files in the current directory
for %%f in (*.csv) do (
echo Processing file %%f

REM If it's the first file, copy the whole file including the header
if !first_file!==1 (
    type "%%f" >> %output_file%
    set first_file=0
) else (
    REM For subsequent files, skip the first line (header)
    for /f "skip=1 delims=" %%a in (%%f) do (
        echo %%a >> %output_file%
    )
)

)

echo Merge complete. Output file: %output_file%
endlocal

gitch10 · 02-07-2024 11:56am

@echo off
setlocal enabledelayedexpansion

REM Output file name
set output_file=merged_output.csv

REM Check if output file already exists and delete it if it does
if exist %output_file% del %output_file%

REM Initialize a flag to indicate the first file
set first_file=1

REM Loop through all CSV files in the current directory
for %%f in (*.csv) do (
echo Processing file %%f

REM If it's the first file, copy the whole file including the header
if !first_file! equ 1 (
    type "%%f" >> %output_file%
    set first_file=0
) else (
    REM For subsequent files, skip the first line (header)
    more +1 "%%f" >> %output_file%
)

)

echo Merge complete. Output file: %output_file%
endlocal

gitch10 · 02-07-2024 12:20pm

@echo off
setlocal enabledelayedexpansion

REM Input and output file names
set input_file=input.csv
set output_file=filtered_output.csv

REM Check if output file already exists and delete it if it does
if exist %output_file% del %output_file%

REM Loop through each line of the input file
for /f "delims=" %%a in (%input_file%) do (
set line=%%a
REM Check if the first four characters are "Bank"
if not "!line:~0,4!"=="Bank" (
echo %%a >> %output_file%
)
)

echo Filtering complete. Output file: %output_file%
endlocal

gitch10 · 03-07-2024 2:44pm

Sub ParseTextFile()
Dim FilePath As String
Dim FileNumber As Integer
Dim LineText As String
Dim RowNumber As Long
Dim RegEx As Object
Dim Matches As Object

' Define the file path
FilePath = "C:\path\to\your\textfile.txt"

' Get a free file number
FileNumber = FreeFile

' Open the text file
Open FilePath For Input As #FileNumber

' Create the regular expression object
Set RegEx = CreateObject("VBScript.RegExp")
With RegEx
    .Global = True
    .IgnoreCase = True
    .Pattern = "(90\d{4})(.*?)(\s.*?)(\d{2}/\d{2}/\d{4})"
End With

' Initialize the row number
RowNumber = 1

' Loop through each line in the text file
Do While Not EOF(FileNumber)
    Line Input #FileNumber, LineText
    
    ' Execute the regular expression on the line
    If RegEx.Test(LineText) Then
        Set Matches = RegEx.Execute(LineText)
        
        ' Check if we have the expected number of matches
        If Matches.Count > 0 Then
            ' Extract the four items and write them to the worksheet
            With Matches(0).SubMatches
                Cells(RowNumber, 1).Value = .Item(0) ' First item: 6-digit number beginning with 90
                Cells(RowNumber, 2).Value = Trim(.Item(1)) ' Second item: variable length value
                Cells(RowNumber, 3).Value = Trim(.Item(2)) ' Third item: variable length string
                Cells(RowNumber, 4).Value = .Item(3) ' Fourth item: date dd/mm/yyyy
            End With
            
            ' Increment the row number
            RowNumber = RowNumber + 1
        End If
    End If
Loop

' Close the text file
Close #FileNumber

' Release the RegExp object
Set RegEx = Nothing

MsgBox "Data extraction completed!"

End Sub

gitch10 · 03-07-2024 2:53pm

Sub ParseTextFile()
Dim FilePath As String
Dim FileNumber As Integer
Dim LineText As String
Dim RowNumber As Long
Dim RegEx As Object
Dim Matches As Object

' Define the file path
FilePath = "C:\path\to\your\textfile.txt"

' Get a free file number
FileNumber = FreeFile

' Open the text file
Open FilePath For Input As #FileNumber

' Create the regular expression object
Set RegEx = CreateObject("VBScript.RegExp")
With RegEx
    .Global = True
    .IgnoreCase = True
    .Pattern = "(90\d{4})\s+(\d+\.\d{2})\s+(.+?)\s+(\d{2}/\d{2}/\d{4})"
End With

' Initialize the row number
RowNumber = 1

' Loop through each line in the text file
Do While Not EOF(FileNumber)
    Line Input #FileNumber, LineText
    
    ' Execute the regular expression on the line
    If RegEx.Test(LineText) Then
        Set Matches = RegEx.Execute(LineText)
        
        ' Check if we have the expected number of matches
        If Matches.Count > 0 Then
            ' Extract the four items and write them to the worksheet
            With Matches(0).SubMatches
                Cells(RowNumber, 1).Value = .Item(0) ' First item: 6-digit number beginning with 90
                Cells(RowNumber, 2).Value = .Item(1) ' Second item: numeric value with two decimal places
                Cells(RowNumber, 3).Value = .Item(2) ' Third item: variable length string
                Cells(RowNumber, 4).Value = .Item(3) ' Fourth item: date dd/mm/yyyy
            End With
            
            ' Increment the row number
            RowNumber = RowNumber + 1
        End If
    End If
Loop

' Close the text file
Close #FileNumber

' Release the RegExp object
Set RegEx = Nothing

MsgBox "Data extraction completed!"

End Sub

gitch10 · 03-07-2024 3:07pm

Sub ParseTextFile()
Dim FilePath As String
Dim FileNumber As Integer
Dim LineText As String
Dim RowNumber As Long
Dim RegEx As Object
Dim Matches As Object

' Define the file path
FilePath = "C:\path\to\your\textfile.txt"

' Get a free file number
FileNumber = FreeFile

' Open the text file
Open FilePath For Input As #FileNumber

' Create the regular expression object
Set RegEx = CreateObject("VBScript.RegExp")
With RegEx
    .Global = True
    .IgnoreCase = True
    ' Updated pattern to account for numbers less than 1
    .Pattern = "(9\d{5})\s+(\d*\.\d{2})\s+(.+?)\s+(\d{2}/\d{2}/\d{4})"
End With

' Initialize the row number
RowNumber = 1

' Loop through each line in the text file
Do While Not EOF(FileNumber)
    Line Input #FileNumber, LineText
    
    ' Execute the regular expression on the line
    If RegEx.Test(LineText) Then
        Set Matches = RegEx.Execute(LineText)
        
        ' Check if we have the expected number of matches
        If Matches.Count > 0 Then
            ' Extract the four items and write them to the worksheet
            With Matches(0).SubMatches
                Cells(RowNumber, 1).Value = .Item(0) ' First item: 6-digit number beginning with 9
                Cells(RowNumber, 2).Value = .Item(1) ' Second item: numeric value with two decimal places
                Cells(RowNumber, 3).Value = .Item(2) ' Third item: variable length string
                Cells(RowNumber, 4).Value = .Item(3) ' Fourth item: date dd/mm/yyyy
            End With
            
            ' Increment the row number
            RowNumber = RowNumber + 1
        End If
    End If
Loop

' Close the text file
Close #FileNumber

' Release the RegExp object
Set RegEx = Nothing

MsgBox "Data extraction completed!"

End Sub

gitch10 · 16-07-2024 4:21pm

Sub CopyAndPasteNonContiguousColumnsWithTimestamp()
Dim sourceWorkbook As Workbook
Dim sourceSheet As Worksheet
Dim destWorkbook As Workbook
Dim destSheet As Worksheet
Dim templatePath As String
Dim savePath As String
Dim currentDateTime As String
Dim lastRow As Long
Dim col As Long
Dim srcCols As Variant
Dim destCols As Variant
Dim i As Integer

' Set the source workbook and sheet
Set sourceWorkbook = ThisWorkbook
Set sourceSheet = sourceWorkbook.ActiveSheet

' Define the template path (update this path as needed)
templatePath = "C:\Path\To\Your\Template.xlsx"

' Open the template workbook as read-only
Set destWorkbook = Workbooks.Open(templatePath, ReadOnly:=True)
Set destSheet = destWorkbook.Sheets(1)

' Find the last row of data in the source sheet (update column reference as needed)
lastRow = sourceSheet.Cells(sourceSheet.Rows.Count, "C").End(xlUp).Row

' Define the columns to copy (C, D, P, BA)
srcCols = Array("C", "D", "P", "BA")
' Define the destination columns (A, B, C, D) in the template workbook
destCols = Array("A", "B", "C", "D")

' Copy and paste each column
For i = LBound(srcCols) To UBound(srcCols)
    sourceSheet.Range(srcCols(i) & "6:" & srcCols(i) & lastRow).Copy
    destSheet.Range(destCols(i) & "2").PasteSpecial Paste:=xlPasteValues
Next i

' Generate the current date and time string for the filename
currentDateTime = Format(Now, "yyyy-mm-dd_hh-mm-ss")

' Define the save path in the root of the P drive with date and time stamp
savePath = "P:\" & "DestinationWorkbook_" & currentDateTime & ".xlsx"

' Save the destination workbook as .xlsx
destWorkbook.SaveAs Filename:=savePath, FileFormat:=xlOpenXMLWorkbook

' Close the destination workbook
destWorkbook.Close SaveChanges:=False

' Notify the user
MsgBox "Data copied and new workbook saved as " & savePath, vbInformation

End Sub

gitch10 · 16-07-2024 5:14pm

Sub CopyAndPasteNonContiguousColumnsWithFilePicker()
Dim sourceWorkbook As Workbook
Dim sourceSheet As Worksheet
Dim destWorkbook As Workbook
Dim destSheet As Worksheet
Dim templatePath As String
Dim savePath As String
Dim currentDateTime As String
Dim lastRow As Long
Dim startingRow As Long
Dim columnsToCopy As Variant
Dim col As Long
Dim i As Integer
Dim destCols As Variant
Dim fileDialog As FileDialog
Dim selectedFile As String

' Set the template path (update this path as needed)
templatePath = "C:\Path\To\Your\Template.xlsx"

' Prompt user to select the source file
Set fileDialog = Application.FileDialog(msoFileDialogOpen)
fileDialog.Title = "Select the Source File"
fileDialog.Filters.Clear
fileDialog.Filters.Add "Excel Files", "*.xlsx; *.xlsm; *.xlsb; *.xls"
fileDialog.AllowMultiSelect = False

If fileDialog.Show = -1 Then
    selectedFile = fileDialog.SelectedItems(1)
Else
    MsgBox "No file selected. Process aborted.", vbExclamation
    Exit Sub
End If

' Open the selected source workbook
Set sourceWorkbook = Workbooks.Open(selectedFile)
Set sourceSheet = sourceWorkbook.Sheets(1) ' Adjust if needed to specify a different sheet

' Get the starting row from the named range
startingRow = sourceSheet.Range("StartingRow").Value

' Get the columns to copy from the named range
columnsToCopy = sourceSheet.Range("ColumnsToCopy").Value

' Find the last row of data in the source sheet (assuming the first column to copy)
lastRow = sourceSheet.Cells(sourceSheet.Rows.Count, columnsToCopy(1, 1)).End(xlUp).Row

' Define the destination columns (A, B, C, D, ...) in the template workbook
' Adjust this array based on the number of columns in ColumnsToCopy
destCols = Array("A", "B", "C", "D", "E", "F", "G", "H", "I", "J")

' Open the template workbook as read-only
Set destWorkbook = Workbooks.Open(templatePath, ReadOnly:=True)
Set destSheet = destWorkbook.Sheets(1)

' Copy and paste each column
For i = LBound(columnsToCopy, 1) To UBound(columnsToCopy, 1)
    sourceSheet.Range(columnsToCopy(i, 1) & startingRow & ":" & columnsToCopy(i, 1) & lastRow).Copy
    destSheet.Range(destCols(i) & "2").PasteSpecial Paste:=xlPasteValues
Next i

' Generate the current date and time string for the filename
currentDateTime = Format(Now, "yyyy-mm-dd_hh-mm-ss")

' Define the save path in the root of the P drive with date and time stamp
savePath = "P:\" & "DestinationWorkbook_" & currentDateTime & ".xlsx"

' Save the destination workbook as .xlsx
destWorkbook.SaveAs Filename:=savePath, FileFormat:=xlOpenXMLWorkbook

' Close the destination workbook
destWorkbook.Close SaveChanges:=False

' Close the source workbook without saving
sourceWorkbook.Close SaveChanges:=False

' Notify the user
MsgBox "Data copied and new workbook saved as " & savePath, vbInformation

End Sub

gitch10 · 18-07-2024 4:35pm

Sub AggregateAndSum()
Dim ws As Worksheet
Dim summaryWs As Worksheet
Dim lastRow As Long
Dim dict As Object
Dim key As String
Dim cell As Range
Dim i As Long

Set ws = ThisWorkbook.Sheets("Sheet1") ' Change to your sheet name
On Error Resume Next
Set summaryWs = ThisWorkbook.Sheets("Summary")
If summaryWs Is Nothing Then
    Set summaryWs = ThisWorkbook.Sheets.Add
    summaryWs.Name = "Summary"
Else
    summaryWs.Cells.Clear ' Clear existing data
End If
On Error GoTo 0

lastRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row

Set dict = CreateObject("Scripting.Dictionary")

For i = 2 To lastRow
    key = ws.Cells(i, 2).Value & "|" & ws.Cells(i, 5).Value & "|" & ws.Cells(i, 6).Value
    If Not dict.exists(key) Then
        dict.Add key, ws.Cells(i, 3).Value
    Else
        dict(key) = dict(key) + ws.Cells(i, 3).Value
    End If
Next i

summaryWs.Cells(1, 1).Value = "Category"
summaryWs.Cells(1, 2).Value = "Subcategory 1"
summaryWs.Cells(1, 3).Value = "Subcategory 2"
summaryWs.Cells(1, 4).Value = "Sum"

i = 2
For Each key In dict.Keys
    Dim parts() As String
    parts = Split(key, "|")
    summaryWs.Cells(i, 1).Value = parts(0)
    summaryWs.Cells(i, 2).Value = parts(1)
    summaryWs.Cells(i, 3).Value = parts(2)
    summaryWs.Cells(i, 4).Value = dict(key)
    i = i + 1
Next key

MsgBox "Aggregation and sum complete!"

End Sub

gitch10 · 19-07-2024 12:24pm

@echo off
setlocal

REM Define the master file and the file to append
set "masterFile=master.txt"
set "fileToAppend=append.txt"

REM Check if the file to append exists
if not exist "%fileToAppend%" (
echo The file "%fileToAppend%" does not exist.
exit /b 1
)

REM Append the contents of the file to the master file
type "%fileToAppend%" >> "%masterFile%"

echo The contents of "%fileToAppend%" have been appended to "%masterFile%".

gitch10 · 22-07-2024 5:53pm

Sub MapJournalToSAPTemplate()
Dim wsSource As Worksheet
Dim wsTarget As Worksheet
Dim lastRow As Long
Dim currentRow As Long
Dim targetRow As Long
Dim currentCurrency As String
Dim newDocument As Boolean

Set wsSource = ThisWorkbook.Sheets("JournalEntries")
Set wsTarget = ThisWorkbook.Sheets("SAPTemplate")

' Initialize
lastRow = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row
currentRow = 2 ' Assuming headers are in row 1
targetRow = 2 ' Assuming headers are in row 1 in SAP Template

Do While currentRow <= lastRow
    ' Check if we need to start a new document
    If wsSource.Cells(currentRow, "G").Value <> currentCurrency Then
        newDocument = True
        currentCurrency = wsSource.Cells(currentRow, "G").Value
    End If
    
    If newDocument Then
        ' Copy Header Information
        wsTarget.Cells(targetRow, 1).Value = wsSource.Cells(currentRow, "A").Value ' Document Date (BLDAT)
        wsTarget.Cells(targetRow, 2).Value = wsSource.Cells(currentRow, "B").Value ' Posting Date (BUDAT)
        wsTarget.Cells(targetRow, 3).Value = wsSource.Cells(currentRow, "C").Value ' Document Type (BLART)
        wsTarget.Cells(targetRow, 4).Value = wsSource.Cells(currentRow, "D").Value ' Document Number (BELNR)
        wsTarget.Cells(targetRow, 5).Value = wsSource.Cells(currentRow, "E").Value ' Company Code (BUKRS)
        wsTarget.Cells(targetRow, 6).Value = wsSource.Cells(currentRow, "F").Value ' Reference Number (XBLNR)
        wsTarget.Cells(targetRow, 7).Value = wsSource.Cells(currentRow, "G").Value ' Currency (WAERS)
        wsTarget.Cells(targetRow, 8).Value = wsSource.Cells(currentRow, "H").Value ' Posting Period (MONAT)
        wsTarget.Cells(targetRow, 9).Value = wsSource.Cells(currentRow, "I").Value ' Document Header Text (BKTXT)
        wsTarget.Cells(targetRow, 10).Value = wsSource.Cells(currentRow, "J").Value ' Fiscal Year (GJAHR)
        wsTarget.Cells(targetRow, 11).Value = wsSource.Cells(currentRow, "K").Value ' User ID (USNAM)
        targetRow = targetRow + 1
        newDocument = False
    End If
    
    ' Copy Line Item Information
    wsTarget.Cells(targetRow, 1).Value = wsSource.Cells(currentRow, "L").Value ' Account Number (HKONT)
    wsTarget.Cells(targetRow, 2).Value = wsSource.Cells(currentRow, "M").Value ' Debit/Credit Indicator (SHKZG)
    wsTarget.Cells(targetRow, 3).Value = wsSource.Cells(currentRow, "N").Value ' Amount (WRBTR)
    wsTarget.Cells(targetRow, 4).Value = wsSource.Cells(currentRow, "O").Value ' Cost Center (KOSTL)
    wsTarget.Cells(targetRow, 5).Value = wsSource.Cells(currentRow, "P").Value ' Profit Center (PRCTR)
    wsTarget.Cells(targetRow, 6).Value = wsSource.Cells(currentRow, "D").Value ' Document Number (BELNR)
    wsTarget.Cells(targetRow, 7).Value = wsSource.Cells(currentRow, "E").Value ' Company Code (BUKRS)
    wsTarget.Cells(targetRow, 8).Value = wsSource.Cells(currentRow, "Q").Value ' Posting Key (BSCHL)
    wsTarget.Cells(targetRow, 9).Value = wsSource.Cells(currentRow, "R").Value ' Text (SGTXT)
    wsTarget.Cells(targetRow, 10).Value = wsSource.Cells(currentRow, "S").Value ' Assignment (ZUONR)
    wsTarget.Cells(targetRow, 11).Value = wsSource.Cells(currentRow, "T").Value ' Business Area (GSBER)
    wsTarget.Cells(targetRow, 12).Value = wsSource.Cells(currentRow, "U").Value ' Segment (SEGMENT)
    
    currentRow = currentRow + 1
    targetRow = targetRow + 1
Loop

End Sub

gitch10 · 22-07-2024 5:54pm

Sub MapJournalToSAPTemplate()
Dim conn As Object
Dim rs As Object
Dim strConn As String
Dim strSQL As String

Dim wsTarget As Worksheet
Dim targetRow As Long
Dim currentCurrency As String
Dim newDocument As Boolean

' Set the worksheet for the SAP template
Set wsTarget = ThisWorkbook.Sheets("SAPTemplate")

' Initialize the target row
targetRow = 2 ' Assuming headers are in row 1 in SAP Template

' Connection string to the Access database
strConn = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=C:\Path\To\Your\Database.accdb;"

' SQL query to retrieve data from tblSAP
strSQL = "SELECT * FROM tblSAP ORDER BY WAERS, DocumentDate"

' Create a new ADO connection
Set conn = CreateObject("ADODB.Connection")
conn.Open strConn

' Create a new ADO recordset
Set rs = CreateObject("ADODB.Recordset")
rs.Open strSQL, conn, 1, 3 ' 1 = adOpenKeyset, 3 = adLockOptimistic

' Check if the recordset is empty
If rs.EOF And rs.BOF Then
    MsgBox "No data found in tblSAP.", vbExclamation
    rs.Close
    conn.Close
    Exit Sub
End If

' Move to the first record
rs.MoveFirst

' Loop through the records
Do While Not rs.EOF
    ' Check if we need to start a new document
    If rs.Fields("WAERS").Value <> currentCurrency Then
        newDocument = True
        currentCurrency = rs.Fields("WAERS").Value
    End If
    
    If newDocument Then
        ' Copy Header Information
        wsTarget.Cells(targetRow, 1).Value = rs.Fields("DocumentDate").Value ' Document Date (BLDAT)
        wsTarget.Cells(targetRow, 2).Value = rs.Fields("PostingDate").Value ' Posting Date (BUDAT)
        wsTarget.Cells(targetRow, 3).Value = rs.Fields("DocumentType").Value ' Document Type (BLART)
        wsTarget.Cells(targetRow, 4).Value = rs.Fields("DocumentNumber").Value ' Document Number (BELNR)
        wsTarget.Cells(targetRow, 5).Value = rs.Fields("CompanyCode").Value ' Company Code (BUKRS)
        wsTarget.Cells(targetRow, 6).Value = rs.Fields("ReferenceNumber").Value ' Reference Number (XBLNR)
        wsTarget.Cells(targetRow, 7).Value = rs.Fields("Currency").Value ' Currency (WAERS)
        wsTarget.Cells(targetRow, 8).Value = rs.Fields("PostingPeriod").Value ' Posting Period (MONAT)
        wsTarget.Cells(targetRow, 9).Value = rs.Fields("DocumentHeaderText").Value ' Document Header Text (BKTXT)
        wsTarget.Cells(targetRow, 10).Value = rs.Fields("FiscalYear").Value ' Fiscal Year (GJAHR)
        wsTarget.Cells(targetRow, 11).Value = rs.Fields("UserID").Value ' User ID (USNAM)
        targetRow = targetRow + 1
        newDocument = False
    End If
    
    ' Copy Line Item Information
    wsTarget.Cells(targetRow, 1).Value = rs.Fields("AccountNumber").Value ' Account Number (HKONT)
    wsTarget.Cells(targetRow, 2).Value = rs.Fields("DebitCreditIndicator").Value ' Debit/Credit Indicator (SHKZG)
    wsTarget.Cells(targetRow, 3).Value = rs.Fields("Amount").Value ' Amount (WRBTR)
    wsTarget.Cells(targetRow, 4).Value = rs.Fields("CostCenter").Value ' Cost Center (KOSTL)
    wsTarget.Cells(targetRow, 5).Value = rs.Fields("ProfitCenter").Value ' Profit Center (PRCTR)
    wsTarget.Cells(targetRow, 6).Value = rs.Fields("DocumentNumber").Value ' Document Number (BELNR)
    wsTarget.Cells(targetRow, 7).Value = rs.Fields("CompanyCode").Value ' Company Code (BUKRS)
    wsTarget.Cells(targetRow, 8).Value = rs.Fields("PostingKey").Value ' Posting Key (BSCHL)
    wsTarget.Cells(targetRow, 9).Value = rs.Fields("Text").Value ' Text (SGTXT)
    wsTarget.Cells(targetRow, 10).Value = rs.Fields("Assignment").Value ' Assignment (ZUONR)
    wsTarget.Cells(targetRow, 11).Value = rs.Fields("BusinessArea").Value ' Business Area (GSBER)
    wsTarget.Cells(targetRow, 12).Value = rs.Fields("Segment").Value ' Segment (SEGMENT)
    
    ' Move to the next record
    rs.MoveNext
    targetRow = targetRow + 1
Loop

' Close the recordset and connection
rs.Close
conn.Close

' Clean up
Set rs = Nothing
Set conn = Nothing

MsgBox "Data mapping to SAP template is complete.", vbInformation

End Sub

gitch10 · 22-07-2024 5:54pm

Private Sub cmdExportToExcel_Click()
Dim conn As Object
Dim rs As Object
Dim xlApp As Object
Dim xlWB As Object
Dim xlWS As Object
Dim strConn As String
Dim strSQL As String
Dim targetRow As Long
Dim currentCurrency As String
Dim newDocument As Boolean

' SQL query to retrieve data from tblSAP
strSQL = "SELECT * FROM tblSAP ORDER BY WAERS, DocumentDate"

' Create a new ADO connection
Set conn = CreateObject("ADODB.Connection")
conn.Open CurrentProject.Connection

' Create a new ADO recordset
Set rs = CreateObject("ADODB.Recordset")
rs.Open strSQL, conn, 1, 3 ' 1 = adOpenKeyset, 3 = adLockOptimistic

' Check if the recordset is empty
If rs.EOF And rs.BOF Then
    MsgBox "No data found in tblSAP.", vbExclamation
    rs.Close
    conn.Close
    Exit Sub
End If

' Create a new instance of Excel
Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = True

' Open the Excel workbook
Set xlWB = xlApp.Workbooks.Open("C:\Path\To\Your\ExcelTemplate.xlsx")
Set xlWS = xlWB.Sheets("SAPTemplate")

' Initialize the target row
targetRow = 2 ' Assuming headers are in row 1 in SAP Template

' Move to the first record
rs.MoveFirst

' Loop through the records
Do While Not rs.EOF
    ' Check if we need to start a new document
    If rs.Fields("WAERS").Value <> currentCurrency Then
        newDocument = True
        currentCurrency = rs.Fields("WAERS").Value
    End If
    
    If newDocument Then
        ' Copy Header Information
        xlWS.Cells(targetRow, 1).Value = rs.Fields("DocumentDate").Value ' Document Date (BLDAT)
        xlWS.Cells(targetRow, 2).Value = rs.Fields("PostingDate").Value ' Posting Date (BUDAT)
        xlWS.Cells(targetRow, 3).Value = rs.Fields("DocumentType").Value ' Document Type (BLART)
        xlWS.Cells(targetRow, 4).Value = rs.Fields("DocumentNumber").Value ' Document Number (BELNR)
        xlWS.Cells(targetRow, 5).Value = rs.Fields("CompanyCode").Value ' Company Code (BUKRS)
        xlWS.Cells(targetRow, 6).Value = rs.Fields("ReferenceNumber").Value ' Reference Number (XBLNR)
        xlWS.Cells(targetRow, 7).Value = rs.Fields("Currency").Value ' Currency (WAERS)
        xlWS.Cells(targetRow, 8).Value = rs.Fields("PostingPeriod").Value ' Posting Period (MONAT)
        xlWS.Cells(targetRow, 9).Value = rs.Fields("DocumentHeaderText").Value ' Document Header Text (BKTXT)
        xlWS.Cells(targetRow, 10).Value = rs.Fields("FiscalYear").Value ' Fiscal Year (GJAHR)
        xlWS.Cells(targetRow, 11).Value = rs.Fields("UserID").Value ' User ID (USNAM)
        targetRow = targetRow + 1
        newDocument = False
    End If
    
    ' Copy Line Item Information
    xlWS.Cells(targetRow, 1).Value = rs.Fields("AccountNumber").Value ' Account Number (HKONT)
    xlWS.Cells(targetRow, 2).Value = rs.Fields("DebitCreditIndicator").Value ' Debit/Credit Indicator (SHKZG)
    xlWS.Cells(targetRow, 3).Value = rs.Fields("Amount").Value ' Amount (WRBTR)
    xlWS.Cells(targetRow, 4).Value = rs.Fields("CostCenter").Value ' Cost Center (KOSTL)
    xlWS.Cells(targetRow, 5).Value = rs.Fields("ProfitCenter").Value ' Profit Center (PRCTR)
    xlWS.Cells(targetRow, 6).Value = rs.Fields("DocumentNumber").Value ' Document Number (BELNR)
    xlWS.Cells(targetRow, 7).Value = rs.Fields("CompanyCode").Value ' Company Code (BUKRS)
    xlWS.Cells(targetRow, 8).Value = rs.Fields("PostingKey").Value ' Posting Key (BSCHL)
    xlWS.Cells(targetRow, 9).Value = rs.Fields("Text").Value ' Text (SGTXT)
    xlWS.Cells(targetRow, 10).Value = rs.Fields("Assignment").Value ' Assignment (ZUONR)
    xlWS.Cells(targetRow, 11).Value = rs.Fields("BusinessArea").Value ' Business Area (GSBER)
    xlWS.Cells(targetRow, 12).Value = rs.Fields("Segment").Value ' Segment (SEGMENT)
    
    ' Move to the next record
    rs.MoveNext
    targetRow = targetRow + 1
Loop

' Close the recordset and connection
rs.Close
conn.Close

' Clean up
Set rs = Nothing
Set conn = Nothing

MsgBox "Data mapping to SAP template is complete.", vbInformation

End Sub

gitch10 · 22-07-2024 5:54pm

Public Sub ExportToExcel()
Dim conn As Object
Dim rs As Object
Dim xlApp As Object
Dim xlWB As Object
Dim xlWS As Object
Dim strSQL As String
Dim targetRow As Long
Dim currentCurrency As String
Dim newDocument As Boolean

' SQL query to retrieve data from tblSAP
strSQL = "SELECT * FROM tblSAP ORDER BY WAERS, DocumentDate"

' Create a new ADO connection
Set conn = CreateObject("ADODB.Connection")
conn.Open CurrentProject.Connection

' Create a new ADO recordset
Set rs = CreateObject("ADODB.Recordset")
rs.Open strSQL, conn, 1, 3 ' 1 = adOpenKeyset, 3 = adLockOptimistic

' Check if the recordset is empty
If rs.EOF And rs.BOF Then
    MsgBox "No data found in tblSAP.", vbExclamation
    rs.Close
    conn.Close
    Exit Sub
End If

' Create a new instance of Excel
Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = True

' Open the Excel workbook
Set xlWB = xlApp.Workbooks.Open("C:\Path\To\Your\ExcelTemplate.xlsx")
Set xlWS = xlWB.Sheets("SAPTemplate")

' Initialize the target row
targetRow = 2 ' Assuming headers are in row 1 in SAP Template

' Move to the first record
rs.MoveFirst

' Loop through the records
Do While Not rs.EOF
    ' Check if we need to start a new document
    If rs.Fields("WAERS").Value <> currentCurrency Then
        newDocument = True
        currentCurrency = rs.Fields("WAERS").Value
    End If

    If newDocument Then
        ' Copy Header Information
        xlWS.Cells(targetRow, 1).Value = rs.Fields("DocumentDate").Value ' Document Date (BLDAT)
        xlWS.Cells(targetRow, 2).Value = rs.Fields("PostingDate").Value ' Posting Date (BUDAT)
        xlWS.Cells(targetRow, 3).Value = rs.Fields("DocumentType").Value ' Document Type (BLART)
        xlWS.Cells(targetRow, 4).Value = rs.Fields("DocumentNumber").Value ' Document Number (BELNR)
        xlWS.Cells(targetRow, 5).Value = rs.Fields("CompanyCode").Value ' Company Code (BUKRS)
        xlWS.Cells(targetRow, 6).Value = rs.Fields("ReferenceNumber").Value ' Reference Number (XBLNR)
        xlWS.Cells(targetRow, 7).Value = rs.Fields("Currency").Value ' Currency (WAERS)
        xlWS.Cells(targetRow, 8).Value = rs.Fields("PostingPeriod").Value ' Posting Period (MONAT)
        xlWS.Cells(targetRow, 9).Value = rs.Fields("DocumentHeaderText").Value ' Document Header Text (BKTXT)
        xlWS.Cells(targetRow, 10).Value = rs.Fields("FiscalYear").Value ' Fiscal Year (GJAHR)
        xlWS.Cells(targetRow, 11).Value = rs.Fields("UserID").Value ' User ID (USNAM)
        targetRow = targetRow + 1
        newDocument = False
    End If

    ' Copy Line Item Information
    xlWS.Cells(targetRow, 1).Value = rs.Fields("AccountNumber").Value ' Account Number (HKONT)
    xlWS.Cells(targetRow, 2).Value = rs.Fields("DebitCreditIndicator").Value ' Debit/Credit Indicator (SHKZG)
    xlWS.Cells(targetRow, 3).Value = rs.Fields("Amount").Value ' Amount (WRBTR)
    xlWS.Cells(targetRow, 4).Value = rs.Fields("CostCenter").Value ' Cost Center (KOSTL)
    xlWS.Cells(targetRow, 5).Value = rs.Fields("ProfitCenter").Value ' Profit Center (PRCTR)
    xlWS.Cells(targetRow, 6).Value = rs.Fields("DocumentNumber").Value ' Document Number (BELNR)
    xlWS.Cells(targetRow, 7).Value = rs.Fields("CompanyCode").Value ' Company Code (BUKRS)
    xlWS.Cells(targetRow, 8).Value = rs.Fields("PostingKey").Value ' Posting Key (BSCHL)
    xlWS.Cells(targetRow, 9).Value = rs.Fields("Text").Value ' Text (SGTXT)
    xlWS.Cells(targetRow, 10).Value = rs.Fields("Assignment").Value ' Assignment (ZUONR)
    xlWS.Cells(targetRow, 11).Value = rs.Fields("BusinessArea").Value ' Business Area (GSBER)
    xlWS.Cells(targetRow, 12).Value = rs.Fields("Segment").Value ' Segment (SEGMENT)

    ' Move to the next record
    rs.MoveNext
    targetRow = targetRow + 1
Loop

' Close the recordset and connection
rs.Close
conn.Close

' Clean up
Set rs = Nothing
Set conn = Nothing

MsgBox "Data mapping to SAP template is complete.", vbInformation

End Sub

gitch10 · 22-07-2024 5:55pm

Private Sub cmdExportToExcel_Click()
' Call the ExportToExcel subroutine from the shared library
SharedLibrary.modExportToExcel.ExportToExcel
End Sub

gitch10 · 25-07-2024 2:00pm

Sub RunSAPQuery()
Dim workbook As Workbook
Dim worksheet As Worksheet
Dim analysisApp As Object
Dim analysisQuery As Object
Dim parameters As Object

' Open the workbook
Set workbook = Workbooks.Open("C:\Path\To\Your\Workbook.xlsx")
Set worksheet = workbook.Sheets("Sheet1") ' Adjust sheet name as needed

' Initialize Analysis Application
Set analysisApp = Application.Run("SAPExecuteCommand", "Initialize")

' Specify the query name and parameters
Set analysisQuery = analysisApp.GetDataSource(worksheet.Cells(1, 1).ListObject.QueryTable.Connection)
Set parameters = analysisQuery.Parameters

' Set the Period and Fiscal Year parameters
parameters("PERIOD_FISCYEAR").Value = "001.2024"
parameters("FISCAL_YEAR_PERIOD").Value = "012.2024"

' Refresh the query
analysisQuery.Refresh

' Save and close the workbook
workbook.Save
workbook.Close

End Sub

gitch10 · 25-07-2024 2:26pm

Sub RunSAPQuery()
Dim workbook As Workbook
Dim worksheet As Worksheet
Dim analysisApp As Object
Dim analysisQuery As Object
Dim parameters As Object

' Open the workbook
Set workbook = Workbooks.Open("C:\Path\To\Your\Workbook.xlsx")
Set worksheet = workbook.Sheets("Sheet1") ' Adjust sheet name as needed

' Initialize Analysis Application
On Error Resume Next
Set analysisApp = Application.COMAddIns("SapExcelAddIn").Object
On Error GoTo 0

If analysisApp Is Nothing Then
    MsgBox "SAP Analysis for Office Add-in not found. Please ensure it is installed and enabled.", vbCritical
    Exit Sub
End If

' Specify the query and parameters
Set analysisQuery = analysisApp.GetDataSource(worksheet.Cells(1, 1).ListObject.QueryTable.Connection)
Set parameters = analysisQuery.Parameters

' Set the Period and Fiscal Year parameters
parameters("PERIOD_FISCYEAR").Value = "001.2024"
parameters("FISCAL_YEAR_PERIOD").Value = "012.2024"

' Refresh the query
analysisQuery.Refresh

' Save and close the workbook
workbook.Save
workbook.Close

End Sub

gitch10 · 25-07-2024 2:40pm

Sub RunSAPQuery()
Dim workbook As Workbook
Dim worksheet As Worksheet
Dim analysisApp As Object
Dim dataSource As Object
Dim parameters As Object

' Open the workbook
Set workbook = Workbooks.Open("C:\Path\To\Your\Workbook.xlsx")
Set worksheet = workbook.Sheets("Sheet1") ' Adjust sheet name as needed

' Initialize Analysis Application
On Error Resume Next
Set analysisApp = Application.COMAddIns("SapExcelAddIn").Object
On Error GoTo 0

If analysisApp Is Nothing Then
    MsgBox "SAP Analysis for Office Add-in not found. Please ensure it is installed and enabled.", vbCritical
    Exit Sub
End If

' Specify the data source and parameters
On Error Resume Next
Set dataSource = analysisApp.GetDataSource(worksheet.Name)
On Error GoTo 0

If dataSource Is Nothing Then
    MsgBox "Failed to get the data source. Please check the query connection.", vbCritical
    Exit Sub
End If

Set parameters = dataSource.Parameters

' Set the Period and Fiscal Year parameters
parameters("PERIOD_FISCYEAR").Value = "001.2024"
parameters("FISCAL_YEAR_PERIOD").Value = "012.2024"

' Refresh the query
dataSource.Refresh

' Save and close the workbook
workbook.Save
workbook.Close

End Sub

gitch10 · 25-07-2024 3:30pm

Sub ApplyFiscalPeriodFilter()
Dim workbook As Workbook
Dim worksheet As Worksheet
Dim analysisApp As Object

' Open the workbook
Set workbook = Workbooks.Open("C:\Path\To\Your\Workbook.xlsx") ' Adjust path as needed
Set worksheet = workbook.Sheets("Sheet1") ' Adjust sheet name as needed

' Initialize Analysis Application
On Error Resume Next
Set analysisApp = Application.COMAddIns("SapExcelAddIn").Object
On Error GoTo 0

If analysisApp Is Nothing Then
    MsgBox "SAP Analysis for Office Add-in not found. Please ensure it is installed and enabled.", vbCritical
    Exit Sub
End If

' Apply filter to the data source
' Assumes the filter name for fiscal period is "0FISCPER"
' Replace "0FISCPER" with the actual technical name of your fiscal period filter
analysisApp.Run "SAPSetFilter", worksheet.Name, "0FISCPER", "001.2024,002.2024,003.2024,004.2024,005.2024,006.2024"

' Refresh the workbook to apply the filter
analysisApp.Run "SAPExecuteCommand", "Refresh", "ALL"

' Save and close the workbook
workbook.Save
workbook.Close

End Sub

gitch10 · 07-08-2024 11:29am

Sub GetDataFromSQLServer()
Dim conn As ADODB.Connection
Dim rs As ADODB.Recordset
Dim connectionString As String
Dim sqlQuery As String

' Define your connection string
connectionString = "Provider=SQLOLEDB;Data Source=YourServerName;Initial Catalog=YourDatabaseName;User ID=YourUsername;Password=YourPassword;"

' Define your SQL query
sqlQuery = "SELECT * FROM YourTableName"

' Create a new Connection object
Set conn = New ADODB.Connection

' Open the connection
conn.Open connectionString

' Create a new Recordset object
Set rs = New ADODB.Recordset

' Open the recordset using the SQL query
rs.Open sqlQuery, conn, adOpenStatic, adLockReadOnly

' Check if there are records
If Not rs.EOF Then
    ' Add data to the active sheet starting at cell A1
    With ActiveSheet
        .Cells.Clear
        ' Add headers
        For i = 1 To rs.Fields.Count
            .Cells(1, i).Value = rs.Fields(i - 1).Name
        Next i
        ' Add records
        .Cells(2, 1).CopyFromRecordset rs
    End With
Else
    MsgBox "No records found.", vbInformation
End If

' Close the recordset and the connection
rs.Close
conn.Close

' Clean up
Set rs = Nothing
Set conn = Nothing

MsgBox "Data retrieved successfully.", vbInformation

End Sub

gitch10 · 07-08-2024 11:40am

Sub ImportDataToSQLServer()
Dim conn As ADODB.Connection
Dim rs As ADODB.Recordset
Dim connectionString As String
Dim createTableSQL As String
Dim insertSQL As String
Dim ws As Worksheet
Dim lastRow As Long
Dim lastCol As Long
Dim i As Long, j As Long
Dim tableName As String

' Set the worksheet with the data
Set ws = ThisWorkbook.Sheets("Sheet1") ' Change as needed

' Determine the last row and column with data
lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
lastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column

' Define your connection string
connectionString = "Provider=SQLOLEDB;Data Source=YourServerName;Initial Catalog=YourDatabaseName;User ID=YourUsername;Password=YourPassword;"

' Create a new Connection object
Set conn = New ADODB.Connection

' Open the connection
conn.Open connectionString

' Define the table name
tableName = "YourNewTableName" ' Change as needed

' Create the SQL to create the table
createTableSQL = "CREATE TABLE " & tableName & " ("

' Add the columns from the Excel sheet to the create table SQL
For i = 1 To lastCol
    createTableSQL = createTableSQL & "[" & ws.Cells(1, i).Value & "] NVARCHAR(MAX)"
    If i < lastCol Then
        createTableSQL = createTableSQL & ", "
    End If
Next i
createTableSQL = createTableSQL & ")"

' Execute the create table SQL
conn.Execute createTableSQL

' Loop through the rows and insert data into the table
For i = 2 To lastRow
    insertSQL = "INSERT INTO " & tableName & " VALUES ("
    For j = 1 To lastCol
        insertSQL = insertSQL & "'" & Replace(ws.Cells(i, j).Value, "'", "''") & "'"
        If j < lastCol Then
            insertSQL = insertSQL & ", "
        End If
    Next j
    insertSQL = insertSQL & ")"
    conn.Execute insertSQL
Next i

' Close the connection
conn.Close

' Clean up
Set conn = Nothing

MsgBox "Data imported successfully.", vbInformation

End Sub

namenotavailablE · 07-08-2024 9:12pm

Tab code overview.docx

This might be the wrong forum as it doesn't involve displaying code- more a case of asking for constructive criticism/ suggestions for appearance/ functionality. However, I'm absolutely open to sharing code on request (much of the legacy code is rather clunky and weird due to this project having an earlier project as its foundation, when I was a more rubbishy coder than I am today…)

Below is a cloud link to a workbook I'm working on in advance of the October Budget- 'Fantasy finance Minister'. You get to play at being the Minister for Finance, preparing for the annual Budget. You can apply some income tax changes (PAYE, USC, tax credits, tax bands and so on) and then see how they impact on your pay.

Fantasy Minister for Finance workbook

Once downloaded, you'd need to unblock it for macros to run (a Microsoft requirement- see here)

Feel free to leave any comments here- I check in periodically.

The Word document shows some explanation of how the tabbed shape (shown when the workbook opens) functions.

Useful vba code snipits

Comments