Useful vba code snipits

The approach provided is functional, but it's not the most efficient way to append data to a CSV file in VBA. VBA's I/O operations (like Print #fileNum) can be relatively slow when writing line-by-line, especially for large datasets. We can optimize the solution in several ways:

Key Optimizations:

1. Minimize I/O Operations:

Instead of writing each row directly to the file, accumulate all the data in memory and write it in a single operation. This reduces the overhead caused by frequent file writes.

1. Use a String Array for Efficiency:

Building the CSV data in a String array (or variable) rather than concatenating strings row-by-row improves performance. Concatenating strings in VBA inside loops can be slow due to memory allocation.

1. Eliminate IIf in the Loop:

Using Join to concatenate the column values with a | delimiter is more efficient than manually appending delimiters with IIf.

Optimized VBA Code:

Sub ExportToCSVWithPipeDelimiterOptimized()
Dim ws As Worksheet
Dim filePath As String
Dim lastRow As Long
Dim lastCol As Long
Dim rowNum As Long, colNum As Long
Dim dataToExport As String
Dim rowArray() As String
Dim colArray() As String
Dim fileNum As Integer

' Define the worksheet you want to export (e.g., Sheet1)
Set ws = ThisWorkbook.Sheets("Sheet1")

' Define the file path for the CSV file (change this to your path)
filePath = "C:\your_path\output_file.csv"

' Get 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

' Initialize an array to hold the exported data for each row
ReDim rowArray(1 To lastRow)

' Loop through each row
For rowNum = 1 To lastRow
    ' Initialize an array to hold the column data for each row
    ReDim colArray(1 To lastCol)
    ' Loop through each column in the row
    For colNum = 1 To lastCol
        colArray(colNum) = ws.Cells(rowNum, colNum).Value
    Next colNum
    ' Join the column data into a single string separated by |
    rowArray(rowNum) = Join(colArray, "|")
Next rowNum

' Join all rows into a single string separated by newlines
dataToExport = Join(rowArray, vbCrLf)

' Open the file for appending
fileNum = FreeFile
Open filePath For Append As #fileNum

' Write all the data to the file at once
Print #fileNum, dataToExport

' Close the file
Close #fileNum

MsgBox "Data successfully appended to the CSV file.", vbInformation

End Sub

Key Improvements:

1. String Array for Efficient String Manipulation:

The rowArray() holds all rows' data, and colArray() holds each row's column values. This ensures we process all data in memory before writing to the file, minimizing disk I/O operations.

1. Join Function:

Instead of manually appending | between columns, the Join function does this efficiently. Similarly, all rows are concatenated with vbCrLf (newline) to create the final output string.

1. Single File Write:

Once the data is prepared in memory, it's written to the file in a single operation (Print #fileNum, dataToExport). This reduces the overhead of repeated file access.

Benefits of the Optimized Approach:

Fewer Disk I/O Operations: Writing all data at once is faster, especially for large datasets.

Efficient String Manipulation: Using Join avoids the inefficiency of manually building strings inside loops.

Scalability: This approach will scale better for larger datasets, especially when dealing with thousands of rows and columns.

When Should You Use Each Approach?

Original Approach: Fine for small datasets where performance is not a concern.

Optimized Approach: Ideal for larger datasets, where minimizing disk writes and optimizing string operations can make a significant performance difference.

Let me know if you'd like more refinements!

Sub HighlightMatches()
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim cell As Range
Dim searchRange As Range
Dim foundCell As Range

' Define your sheets
Set ws1 = ThisWorkbook.Sheets("Sheet1")
Set ws2 = ThisWorkbook.Sheets("Sheet2")

' Define the range in Sheet2 column 3 to search
Set searchRange = ws2.Columns(3)

' Loop through each cell in Sheet1 column 2
For Each cell In ws1.Range("B1:B" & ws1.Cells(ws1.Rows.Count, 2).End(xlUp).Row)
    ' Ensure the cell is not empty before processing
    If Len(cell.Value) > 0 Then
        ' Use Find to check if the value exists in Sheet2 column 3
        Set foundCell = searchRange.Find(What:=cell.Value, LookIn:=xlValues, LookAt:=xlWhole)
        
        ' If found, add the text "string found" in column 7 (G) of the same row
        If Not foundCell Is Nothing Then
            ws1.Cells(cell.Row, 7).Value = "string found"
        Else
            ws1.Cells(cell.Row, 7).Value = "" ' Clear the cell if not found (optional)
        End If
    End If
Next cell

End Sub

In SAP FI, specifically in the FBB1 transaction for posting general ledger (GL) items, both fields DMBTR (Amount in Document Currency) and DMBE2 (Amount in Second Local Currency) can be required, depending on the setup of your company's currency configuration in SAP.

Understanding DMBTR and DMBE2

DMBTR: This field represents the amount in the document currency—the currency in which the document is being posted.

DMBE2: This field represents the amount in second local currency, which is used when the company code has more than one local currency enabled.

Why Populate Both DMBTR and DMBE2?

1. Multiple Currencies in Company Code:

If your SAP configuration has multiple local currencies (e.g., group currency, hard currency), SAP requires values in both document currency (DMBTR) and the second local currency (DMBE2) to maintain accurate currency conversion records.

1. Currency Conversion Consistency:

SAP automatically calculates DMBE2 from DMBTR based on the exchange rate if DMBE2 is left blank. However, there are cases where users manually input DMBE2 to ensure consistency or to post an exact amount, particularly if there are rounding or currency exchange considerations.

1. Mandatory Field Settings:

Some configurations make DMBE2 a mandatory field, especially if there is a requirement for precise currency adjustments. This ensures compliance with reporting requirements across different currencies.

Can You Just Populate DMBTR?

Yes, if SAP is configured to allow DMBE2 to default based on DMBTR and the exchange rate, and if there's no specific requirement for a custom amount in DMBE2.

No, if DMBE2 is required by your SAP configuration for accuracy in multi-currency transactions or for compliance with specific reporting needs.

In summary, while in some configurations only DMBTR may be necessary, SAP often requires DMBE2 to ensure accuracy in multi-currency environments. It is best practice to check with your FI team or SAP configuration to confirm if both fields are mandatory in your company’s setup.

Sub CheckStringAnywhereInCell()
Dim ws As Worksheet
Dim checkRange As Range
Dim cell As Range
Dim stringList As Variant
Dim i As Long
Dim matchFound As Boolean
Dim lastRow As Long

' Set the worksheet (change to your sheet name if necessary)
Set ws = ThisWorkbook.Sheets("Sheet1")

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

' Set the range dynamically based on the last row
Set checkRange = ws.Range("A1:A" & lastRow)

' Define the list of strings to check against (company names)
stringList = Array("New Ireland", "Company2", "Company3", "Company4", "Company5", _
                   "Company6", "Company7", "Company8", "Company9", "Company10")

' Loop through each cell in the specified range
For Each cell In checkRange
    matchFound = False
    
    ' Loop through the list of strings
    For i = LBound(stringList) To UBound(stringList)
        ' Use InStr to check if the string appears anywhere in the cell, case-insensitive
        If InStr(1, UCase(cell.Value), UCase(stringList(i)), vbTextCompare) > 0 Then
            matchFound = True
            Exit For ' Exit the loop if a match is found
        End If
    Next i
    
    ' Perform actions based on whether a match was found or not
    If matchFound Then
        ' Action when match is found
        cell.Offset(0, 1).Value = "Match Found"
    Else
        ' Action when no match is found
        cell.Offset(0, 1).Value = "No Match"
    End If
Next cell

End Sub

Sub ImportLatestCSV()
Dim folderPath As String
Dim fileName As String
Dim latestFile As String
Dim latestDate As Date
Dim file As Object
Dim folder As Object
Dim fso As Object

' Set the folder path
folderPath = "C:\path\to\your\folder\" ' Update this path

' Initialize FileSystemObject
Set fso = CreateObject("Scripting.FileSystemObject")
Set folder = fso.GetFolder(folderPath)

' Initialize variables to store latest file information
latestDate = #1/1/1900# ' Set an initial old date

' Loop through each file in the folder
For Each file In folder.Files
    ' Check if the file is a CSV
    If Right(file.Name, 4) = ".csv" Then
        ' Check if this file is the most recently modified
        If file.DateLastModified > latestDate Then
            latestDate = file.DateLastModified
            latestFile = file.Name
        End If
    End If
Next file

' Check if a CSV file was found
If latestFile <> "" Then
    ' Build the full path to the latest CSV file
    fileName = folderPath & latestFile
    
    ' Import the latest CSV file into the active worksheet
    With ActiveSheet.QueryTables.Add(Connection:="TEXT;" & fileName, Destination:=Range("A1"))
        .TextFileConsecutiveDelimiter = False
        .TextFileTabDelimiter = False
        .TextFileSemicolonDelimiter = False
        .TextFileCommaDelimiter = True
        .TextFilePlatform = xlWindows
        .TextFileColumnDataTypes = Array(1) ' All columns as General format
        .Refresh BackgroundQuery:=False
    End With
Else
    MsgBox "No CSV files found in the specified folder.", vbExclamation
End If

' Clean up
Set file = Nothing
Set folder = Nothing
Set fso = Nothing

End Sub

Sub ImportLatestCSV()
Dim folderPath As String
Dim fileName As String
Dim latestFile As String
Dim latestDate As Date
Dim file As Object
Dim folder As Object
Dim fso As Object
Dim headerRow As Range
Dim ws As Worksheet
Dim isValidFile As Boolean

' Set the folder path
folderPath = "C:\path\to\your\folder\" ' Update this path

' Initialize FileSystemObject
Set fso = CreateObject("Scripting.FileSystemObject")
Set folder = fso.GetFolder(folderPath)

' Initialize variables to store latest file information
latestDate = #1/1/1900# ' Set an initial old date

' Loop through each file in the folder
For Each file In folder.Files
    ' Check if the file is a CSV and contains "GB_RPT_PARIS_CASH" anywhere in its name
    If Right(file.Name, 4) = ".csv" And InStr(file.Name, "GB_RPT_PARIS_CASH") > 0 Then
        ' Check if this file is the most recently modified
        If file.DateLastModified > latestDate Then
            latestDate = file.DateLastModified
            latestFile = file.Name
        End If
    End If
Next file

' Check if a matching CSV file was found
If latestFile <> "" Then
    ' Build the full path to the latest CSV file
    fileName = folderPath & latestFile
    
    ' Import only the first row to check headers
    Set ws = ActiveSheet
    With ws.QueryTables.Add(Connection:="TEXT;" & fileName, Destination:=ws.Range("A1"))
        .TextFileConsecutiveDelimiter = False
        .TextFileTabDelimiter = False
        .TextFileSemicolonDelimiter = False
        .TextFileCommaDelimiter = True
        .TextFilePlatform = xlWindows
        .TextFileStartRow = 1
        .TextFileParseType = xlDelimited
        .TextFileColumnDataTypes = Array(1)
        .TextFileTrailingMinusNumbers = True
        .Refresh BackgroundQuery:=False
    End With
    
    ' Check headers
    isValidFile = (ws.Cells(1, 1).Value = "Client_id" And ws.Cells(1, 2).Value = "Security_Sedol")
    
    ' Clear the header row if it's not a valid file
    If isValidFile Then
        ' Re-import the full file, starting at row 1 if headers are valid
        ws.Cells.Clear ' Clear previous partial import
        With ws.QueryTables.Add(Connection:="TEXT;" & fileName, Destination:=ws.Range("A1"))
            .TextFileConsecutiveDelimiter = False
            .TextFileTabDelimiter = False
            .TextFileSemicolonDelimiter = False
            .TextFileCommaDelimiter = True
            .TextFilePlatform = xlWindows
            .TextFileParseType = xlDelimited
            .TextFileColumnDataTypes = Array(1)
            .Refresh BackgroundQuery:=False
        End With
        MsgBox "Data imported successfully from: " & latestFile, vbInformation
    Else
        MsgBox "The latest file does not have the correct headers and will not be imported.", vbExclamation
        ws.Rows(1).Clear ' Clear the header row if headers are invalid
    End If
    
Else
    MsgBox "No matching CSV files found in the specified folder.", vbExclamation
End If

' Clean up
Set file = Nothing
Set folder = Nothing
Set fso = Nothing
Set ws = Nothing

End Sub

Sub ImportNewCSVFiles()
Dim folderPath As String
Dim fileName As String
Dim file As Object
Dim folder As Object
Dim fso As Object
Dim ws As Worksheet
Dim importedFilesSheet As Worksheet
Dim lastRow As Long
Dim importedFiles As Collection
Dim isNewFile As Boolean
Dim currentUser As String
Dim currentDateTime As String
Dim fileCreatedDate As String

' Set the folder path
folderPath = "C:\path\to\your\folder\" ' Update this path

' Set worksheets
Set ws = ActiveSheet ' Worksheet where data will be imported
Set importedFilesSheet = ThisWorkbook.Sheets("ImportedFiles") ' Sheet containing list of imported files

' Get current user and date-time
currentUser = Application.UserName
currentDateTime = Now

' Get list of previously imported files
Set importedFiles = New Collection
On Error Resume Next ' Suppress error if collection item doesn't exist
For Each cell In importedFilesSheet.Range("A1:A" & importedFilesSheet.Cells(importedFilesSheet.Rows.Count, 1).End(xlUp).Row)
    importedFiles.Add cell.Value, CStr(cell.Value) ' Use file name as the key for quick lookup
Next cell
On Error GoTo 0 ' Reset error handling

' Initialize FileSystemObject
Set fso = CreateObject("Scripting.FileSystemObject")
Set folder = fso.GetFolder(folderPath)

' Loop through each file in the folder
For Each file In folder.Files
    ' Check if the file is a CSV and contains "GB_RPT_PARIS_CASH" at position 20
    If Right(file.Name, 4) = ".csv" And Mid(file.Name, 20, 16) = "GB_RPT_PARIS_CASH" Then
        ' Check if the file is not in the imported files list
        On Error Resume Next
        isNewFile = (importedFiles(file.Name) = "")
        On Error GoTo 0
        
        If isNewFile Then
            ' Get the file's creation date and time
            fileCreatedDate = file.DateCreated
            
            ' Import the file
            With ws.QueryTables.Add(Connection:="TEXT;" & folderPath & file.Name, Destination:=ws.Cells(ws.Rows.Count, 1).End(xlUp).Offset(1, 0))
                .TextFileConsecutiveDelimiter = False
                .TextFileTabDelimiter = False
                .TextFileSemicolonDelimiter = False
                .TextFileCommaDelimiter = True
                .TextFilePlatform = xlWindows
                .TextFileParseType = xlDelimited
                .TextFileColumnDataTypes = Array(1)
                .Refresh BackgroundQuery:=False
            End With
            
            ' Add the imported file info to the "ImportedFiles" sheet
            lastRow = importedFilesSheet.Cells(importedFilesSheet.Rows.Count, 1).End(xlUp).Row + 1
            importedFilesSheet.Cells(lastRow, 1).Value = file.Name                   ' Filename
            importedFilesSheet.Cells(lastRow, 2).Value = currentDateTime             ' Import date and time
            importedFilesSheet.Cells(lastRow, 3).Value = currentUser                 ' Username
            importedFilesSheet.Cells(lastRow, 4).Value = fileCreatedDate             ' File created date and time
            MsgBox "Data imported successfully from: " & file.Name, vbInformation
        End If
    End If
Next file

' Clean up
Set file = Nothing
Set folder = Nothing
Set fso = Nothing
Set ws = Nothing
Set importedFilesSheet = Nothing

End Sub

Sub ImportNewCSVFiles()
Dim folderPath As String
Dim ws As Worksheet
Dim importedFilesSheet As Worksheet
Dim importedFiles As Object ' Use a Dictionary for faster lookups
Dim currentUser As String
Dim currentDateTime As String
Dim fileName As String
Dim filePath As String
Dim lastRow As Long
Dim fileCreatedDate As Date
Dim headersAdded As Boolean

' Set the folder path
folderPath = "C:\path\to\your\folder\" ' Update this path

' Set worksheets
Set ws = ActiveSheet ' Worksheet where data will be imported
Set importedFilesSheet = ThisWorkbook.Sheets("ImportedFiles") ' Sheet containing list of imported files

' Remove any existing QueryTables and clear any existing data
On Error Resume Next
Dim qt As QueryTable
For Each qt In ws.QueryTables
    qt.Delete
Next qt
On Error GoTo 0
ws.Cells.ClearContents

' Remove any existing Workbook Connections
Dim conn As WorkbookConnection
On Error Resume Next
For Each conn In ThisWorkbook.Connections
    conn.Delete
Next conn
On Error GoTo 0

' Get current user and date-time
currentUser = Application.UserName
currentDateTime = Now

' Set up the dictionary for previously imported files
Set importedFiles = CreateObject("Scripting.Dictionary")
Dim cell As Range
For Each cell In importedFilesSheet.Range("A2:A" & importedFilesSheet.Cells(importedFilesSheet.Rows.Count, 1).End(xlUp).Row)
    importedFiles(cell.Value) = True
Next cell

' Initialize headers flag
headersAdded = False

' Use Dir to list files, only checking new files and avoiding subfolders for speed
fileName = Dir(folderPath & "*.csv") ' Start with the first CSV file in the folder

Do While fileName <> ""
    ' Check if file is new and meets filename criteria
    If Not importedFiles.exists(fileName) And Mid(fileName, 20, 16) = "GB_RPT_PARIS_CASH" Then
        filePath = folderPath & fileName
        
        ' Get the file's created date
        fileCreatedDate = FileDateTime(filePath)
        
        ' Import the file
        With ws.QueryTables.Add(Connection:="TEXT;" & filePath, Destination:=ws.Cells(ws.Rows.Count, 1).End(xlUp).Offset(1, 0))
            .TextFileConsecutiveDelimiter = False
            .TextFileTabDelimiter = False
            .TextFileSemicolonDelimiter = False
            .TextFileCommaDelimiter = True
            .TextFilePlatform = xlWindows
            .TextFileParseType = xlDelimited
            .TextFileColumnDataTypes = Array(1)
            .TextFileStartRow = IIf(headersAdded, 2, 1) ' Start from row 2 if headers already added
            .Refresh BackgroundQuery:=False
        End With
        
        ' Add the imported file info to the "ImportedFiles" sheet
        lastRow = importedFilesSheet.Cells(importedFilesSheet.Rows.Count, 1).End(xlUp).Row + 1
        importedFilesSheet.Cells(lastRow, 1).Value = fileName                   ' Filename
        importedFilesSheet.Cells(lastRow, 2).Value = currentDateTime             ' Import date and time
        importedFilesSheet.Cells(lastRow, 3).Value = currentUser                 ' Username
        importedFilesSheet.Cells(lastRow, 4).Value = fileCreatedDate             ' File created date and time

        ' Mark headers as added after the first file
        headersAdded = True
        
        ' Add the file to the dictionary to prevent re-importing in the same run
        importedFiles(fileName) = True
    End If

    ' Move to the next file
    fileName = Dir
Loop

' Clean up
Set importedFiles = Nothing
Set ws = Nothing
Set importedFilesSheet = Nothing

End Sub

Sub MoveRowsBasedOnColumnValueOptimized()
Dim srcSheet As Worksheet
Dim destSheet As Worksheet
Dim lastRow As Long
Dim lastDestRow As Long
Dim rng As Range

' Define the source and destination sheets
Set srcSheet = ThisWorkbook.Sheets("SourceSheet") ' Replace with your source sheet name
Set destSheet = ThisWorkbook.Sheets("DestinationSheet") ' Replace with your destination sheet name

' Disable screen updating and automatic calculation for speed
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

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

' Find the last row in the destination sheet
lastDestRow = destSheet.Cells(destSheet.Rows.Count, 1).End(xlUp).Row + 1

' Apply filter on Column 6 (F) to show only rows with "Y"
With srcSheet
    .AutoFilterMode = False
    .Range("A1").AutoFilter Field:=6, Criteria1:="Y"
    
    ' Check if there are any visible cells after applying the filter
    If Application.WorksheetFunction.Subtotal(103, .Range("F2:F" & lastRow)) > 0 Then
        ' Set the range to the visible cells excluding the header
        Set rng = .Range("A2:A" & lastRow).SpecialCells(xlCellTypeVisible).EntireRow
        
        ' Copy visible cells directly to the destination sheet without using the clipboard
        destSheet.Cells(lastDestRow, 1).Resize(rng.Rows.Count, rng.Columns.Count).Value = rng.Value
        
        ' Delete the copied rows from the source sheet in one go
        rng.Delete Shift:=xlUp
    End If
End With

' Turn off the filter and restore settings
srcSheet.AutoFilterMode = False
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

End Sub

Option Compare Database
Option Explicit

Sub ImportCSVWithBatchIDAndTimestamp()
Dim db As DAO.Database
Dim rst As DAO.Recordset
Dim csvFilePath As String
Dim batchID As String
Dim timestamp As Date
Dim logFilePath As String
Dim logFile As Integer
Dim lineData As String
Dim transactionRef As String
Dim importFields() As String

' Initialize database and set variables
Set db = CurrentDb
csvFilePath = InputBox("Enter the full path to the CSV file:", "Select CSV File")
If csvFilePath = "" Then Exit Sub

batchID = "BATCH20231114"  ' Example batch ID; adjust as needed
timestamp = Now
logFilePath = CurrentProject.Path & "\ImportLog.txt"

' Open log file for error logging
logFile = FreeFile
Open logFilePath For Append As #logFile
Print #logFile, "----- Import Log for " & Now & " -----"

' Open CSV file and read data line by line
Dim csvFile As Integer
csvFile = FreeFile
Open csvFilePath For Input As #csvFile

' Start transaction to handle record insertions
db.BeginTrans

Do While Not EOF(csvFile)
    Line Input #csvFile, lineData
    importFields = Split(lineData, "|")
    
    ' Map fields from CSV; adjust field indexes as needed
    transactionRef = importFields(0)  ' Assuming transaction ref is the first field
    
    ' Try inserting into table
    On Error Resume Next
    Set rst = db.OpenRecordset("SELECT * FROM YourTableName", dbOpenDynaset)
    
    ' Check for primary key constraint violation
    If rst.NoMatch Then
        ' Add new record
        rst.AddNew
        rst!TransactionRef = transactionRef
        rst!Timestamp = timestamp
        rst!BatchID = batchID
        ' Add additional fields here as needed
        ' rst!FieldName = importFields(index)
        
        rst.Update
    Else
        ' Log duplicate key error
        Print #logFile, "Primary key violation for TransactionRef: " & transactionRef & " at " & Now
    End If
    
    ' Clean up and proceed
    Set rst = Nothing
    On Error GoTo 0
Loop

' Commit transaction
db.CommitTrans

' Close files and clean up
Close #csvFile
Close #logFile
Set db = Nothing

MsgBox "Import completed. Errors (if any) logged to " & logFilePath, vbInformation

End Sub

Sub ClearFormattingForMultipleSheets()
Dim wsNames As Variant
Dim ws As Worksheet
Dim lastRow As Long
Dim lastCol As Long
Dim i As Long

' Define the names of the worksheets
wsNames = Array("Sheet1", "Sheet2", "Sheet3", "Sheet4") ' Update these names as needed

' Loop through each specified worksheet
For i = LBound(wsNames) To UBound(wsNames)
    On Error Resume Next
    Set ws = ThisWorkbook.Worksheets(wsNames(i))
    On Error GoTo 0

    If Not ws Is Nothing Then
        ' Clear formatting for the worksheet except the first row
        With ws
            lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
            lastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column

            If lastRow > 1 Then
                .Range(.Cells(2, 1), .Cells(lastRow, lastCol)).ClearFormats
            End If
        End With
    Else
        MsgBox "Worksheet '" & wsNames(i) & "' not found.", vbExclamation
    End If
Next i

MsgBox "Formatting cleared from all rows except the first row for specified sheets.", vbInformation

End Sub

Sub AdjustValueDate()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim lastRow1 As Long, lastRow2 As Long
Dim rng1 As Range, rng2 As Range
Dim cell As Range
Dim refValue As String
Dim found As Range
Dim valueDate As Date
Dim newDate As Date

' Set worksheets
Set ws1 = ThisWorkbook.Sheets("Sheet1")
Set ws2 = ThisWorkbook.Sheets("Sheet2")

' Find last row in both sheets
lastRow1 = ws1.Cells(ws1.Rows.Count, 1).End(xlUp).Row
lastRow2 = ws2.Cells(ws2.Rows.Count, 1).End(xlUp).Row

' Set ranges for lookup
Set rng1 = ws1.Range("A2:A" & lastRow1) ' Assuming headers in row 1
Set rng2 = ws2.Range("A2:A" & lastRow2)

' Loop through each bank reference in Sheet1
For Each cell In rng1
    refValue = cell.Value
    Set found = rng2.Find(What:=refValue, LookAt:=xlWhole)
    
    ' If not found in Sheet2
    If found Is Nothing Then
        valueDate = cell.Offset(0, 1).Value ' Get value date from column B
        
        ' Adjust date based on the weekday
        Select Case Weekday(valueDate, vbMonday)
            Case 5 ' Friday
                newDate = valueDate + 3
            Case 6 ' Saturday
                newDate = valueDate + 2
            Case 7 ' Sunday
                newDate = valueDate + 1
            Case Else ' Any other day
                newDate = valueDate + 1
        End Select
        
        ' Update new date in column B
        cell.Offset(0, 1).Value = newDate
    End If
Next cell

MsgBox "Value Dates Updated Successfully!", vbInformation

End Sub

Sub FindEmbeddedNumbers()
Dim strInput As String
Dim i As Long, strLen As Long
Dim currentSub As String
Dim results As String

' Example complex string; replace this with your actual input
strInput = "Random digits: 06023123489, 81234567891, 99123456, 1602345678."
strLen = Len(strInput)
results = ""

' Scan every character
For i = 1 To strLen - 7
    currentSub = Mid(strInput, i, 8)
    
    ' Check if it is entirely numeric
    If IsNumeric(currentSub) Then
        ' Check if it starts with 60, 1, or 8
        If Left(currentSub, 2) = "60" Or Left(currentSub, 1) = "1" Or Left(currentSub, 1) = "8" Then
            ' Add to results
            If results = "" Then
                results = currentSub
            Else
                results = results & ", " & currentSub
            End If
        End If
    End If
Next i

' Output results to adjacent cell
ActiveCell.Offset(0, 1).Value = results
Debug.Print results

End Sub

Sub FindUniqueEmbeddedNumbers()
Dim strInput As String
Dim i As Long, strLen As Long
Dim currentSub As String
Dim results As String
Dim numDict As Object ' Dictionary to store unique numbers

' Example input string with special characters
strInput = "Random: @#60123456, 81234567, 60123456, 1602345678, 81234567!! 99123456."
strLen = Len(strInput)

' Initialize Dictionary to track unique numbers
Set numDict = CreateObject("Scripting.Dictionary")

' Scan through each character, extracting 8-digit sequences
For i = 1 To strLen
    ' Extract potential 8-digit substring
    If i + 7 <= strLen Then
        currentSub = Mid(strInput, i, 8)
        
        ' Check if it's fully numeric
        If IsNumeric(currentSub) Then
            ' Check if it starts with 60, 1, or 8 and is unique
            If Left(currentSub, 2) = "60" Or Left(currentSub, 1) = "1" Or Left(currentSub, 1) = "8" Then
                If Not numDict.exists(currentSub) Then
                    numDict.Add currentSub, True
                End If
            End If
        End If
    End If
Next i

' Convert dictionary keys to comma-separated string
If numDict.Count > 0 Then
    results = Join(numDict.keys, ", ")
Else
    results = "No valid numbers found"
End If

' Output results to adjacent cell
ActiveCell.Offset(0, 1).Value = results
Debug.Print results

End Sub