Useful vba code snipits

gitch10

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

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

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

' 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

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

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

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

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

@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

@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

@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

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

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

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