Useful vba code snipits

gitch10

Just a place for useful vba code and discussion

gitch10

VBA code to find eight digit number beginning with 8 in a long string ?

Function FindEightDigitNumber(inputString As String) As String

  Dim regex As Object

  Set regex = CreateObject("VBScript.RegExp")

   

  ' Define the pattern for an eight-digit number starting with 8

  regex.Pattern = "\b8\d{7}\b"

   

  ' Check if a match is found

  If regex.Test(inputString) Then

    ' Return the first match

    FindEightDigitNumber = regex.Execute(inputString)(0)

  Else

    ' Return an empty string if no match is found

    FindEightDigitNumber = ""

  End If

End Function

namenotavailablE

Here's a Dropbox link to a workbook I created some time ago. It has the bones of a Help panel system which could be useful for providing guidance to users of a complex workbook.

https://www.dropbox.com/scl/fi/zzl1bu3moi7u2vkavu5s3/Help-system-proposal.xlsm?rlkey=vdcqpk9hkn663zxan28chbkxv&dl=0

gitch10

Handy to change row colour

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

If Target.Row > 1 Then ' Exclude header row

If Target.EntireRow.Interior.Color = RGB(0, 255, 0) Then

Target.EntireRow.Interior.Color = RGB(255, 255, 255) ' Change to white fill

Else

Target.EntireRow.Interior.Color = RGB(0, 255, 0) ' Change to green fill

End If

Cancel = True ' Prevent default behavior (editing cell) when double-clicking

End If

End Sub

gitch10

And !! Unprotect worksheet

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

  Dim ws As Worksheet

  Set ws = ThisWorkbook.Sheets("Sheet1") ' Replace "Sheet1" with your actual sheet name

   

  ' Check if the double-click is on a row

  If Target.Row > 0 Then

    ' Unprotect worksheet

    ws.Unprotect Password:="YourPassword" ' Replace "YourPassword" with your actual password

     

    ' Check the current fill color of the row

    If Target.Interior.Color = RGB(255, 255, 255) Then

      ' If white, turn it green

      Target.EntireRow.Interior.Color = RGB(0, 255, 0)

    Else

      ' If green, turn it back to white

      Target.EntireRow.Interior.Color = RGB(255, 255, 255)

    End If

     

    ' Protect worksheet again

    ws.Protect Password:="YourPassword" ' Replace "YourPassword" with your actual password

  End If

   

  Cancel = True ' Cancel default double-click behavior

End Sub

gitch10

And some more to use PowerShell script and excel

# Set the path to your Excel file

$excelFilePath = "C:\Path\To\Your\File.xlsx"

# Create a new Excel application

$excel = New-Object -ComObject Excel.Application

# Make Excel visible (optional)

$excel.Visible = $true

# Open the Excel file

$workbook = $excel.Workbooks.Open($excelFilePath)

# Reference the first sheet (you may need to adjust this based on your Excel file)

$worksheet = $workbook.Sheets.Item(1)

# Run first macro

$excel.Run("YourFirstMacroName")

# Run second macro

$excel.Run("YourSecondMacroName")

# Save the changes

$workbook.Save()

# Close Excel

$excel.Quit()

# Release the Excel objects from memory

[System.Runtime.Interopservices.Marshal]::ReleaseComObject($worksheet) | Out-Null

[System.Runtime.Interopservices.Marshal]::ReleaseComObject($workbook) | Out-Null

[System.Runtime.Interopservices.Marshal]::ReleaseComObject($excel) | Out-Null

# Remove any remaining Excel processes

Get-Process Excel | ForEach-Object { Stop-Process $_.Id -Force }

Flinty997

Why do you use power shell to run excel.

gitch10

How to Add a filter to a cell in xl !!

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

  ' Check if only one cell is selected

  If Target.Cells.Count = 1 Then

    ' Check if the selected cell is not empty

    If Target.Value <> "" Then

      ' Toggle filter on and off based on the selected cell value

      If ActiveSheet.AutoFilterMode Then

        ActiveSheet.AutoFilterMode = False

      Else

        ActiveSheet.UsedRange.AutoFilter Field:=Target.Column, Criteria1:=Target.Value

      End If

    Else

      ' If the selected cell is empty, remove the filter

      ActiveSheet.AutoFilterMode = False

    End If

  End If

End Sub

namenotavailablE

A slightly shorter version of the previous:

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

' Ensure only one cell is selected

 If Target.Cells.Count = 1 Then

   ' If the selected cell is empty, do nothing

   If Target.Value = vbNullString Then

       Exit Sub

   Else

     ' Ensure the filter is off initially and then apply a filter

       ActiveSheet.AutoFilterMode = False

       ActiveSheet.UsedRange.AutoFilter Field:=Target.Column, Criteria1:=Target.Value

   End If

 End If

 End Sub

gitch10

And the latest find a string in multiple text files in a folder using PS ..

# Set the directory path where your text files are located

$directoryPath = "C:\Path\To\Your\Directory"

# Set the string you want to search for

$searchString = "YourSearchString"

# Get all text files in the specified directory

$textFiles = Get-ChildItem -Path $directoryPath -Filter *.txt

# Iterate through each text file and search for the specified string

foreach ($file in $textFiles) {

  $filePath = $file.FullName

  $content = Get-Content $filePath -Raw

  if ($content -match $searchString) {

    Write-Host "String found in file: $filePath"

  } else {

    Write-Host "String not found in file: $filePath"

  }

}

gitch10

New snip ps to combine Cavs

# Set the path to the folder containing your CSV files

$folderPath = "C:\Path\To\Your\CSVFiles"

# Get all CSV files in the folder

$csvFiles = Get-ChildItem -Path $folderPath -Filter *.csv

# Output file path

$outputFilePath = Join-Path $folderPath -ChildPath "output.csv"

# Initialize a flag to skip header for files after the first one

$skipHeader = $false

# Loop through each CSV file and combine into output.csv

foreach ($csvFile in $csvFiles) {

  # Import CSV file

  $data = Import-Csv $csvFile.FullName

  # Skip header if $skipHeader is true

  if ($skipHeader) {

    $data = $data | Select-Object -Skip 1

  } else {

    $skipHeader = $true

  }

  # Append data to output.csv

  $data | Export-Csv -Path $outputFilePath -Append -NoTypeInformation

}

Write-Host "CSV files combined. Output file: $outputFilePath"

gitch10

PS to delete dups

# Specify the path to the folder containing CSV files

$folderPath = "C:\Path\To\Your\Folder"

# Get a list of CSV files in the folder

$csvFiles = Get-ChildItem -Path $folderPath -Filter *.csv

# Create a hashtable to track file hashes

$fileHashes = @{}

# Iterate through each CSV file

foreach ($csvFile in $csvFiles) {

  # Calculate the hash of the file content

  $fileContent = Get-Content $csvFile.FullName -Raw

  $fileHash = Get-Hash -InputObject $fileContent

  # Check if the hash is already in the hashtable

  if ($fileHashes.ContainsKey($fileHash)) {

    # Duplicate found, delete the file

    Remove-Item $csvFile.FullName -Force

    Write-Host "Deleted duplicate file: $($csvFile.Name)"

  } else {

    # Add the hash to the hashtable

    $fileHashes.Add($fileHash, $null)

  }

}

# Function to calculate the hash of a string

function Get-Hash {

  param (

    [Parameter(Mandatory = $true, ValueFromPipeline = $true)]

    [string]$InputObject

  )

  process {

    $hashAlgorithm = [System.Security.Cryptography.SHA256]::Create()

    $hashBytes = $hashAlgorithm.ComputeHash([System.Text.Encoding]::UTF8.GetBytes($InputObject))

    $hash = [BitConverter]::ToString($hashBytes) -replace '-'

    $hashAlgorithm.Dispose()

    $hash

  }

}

gitch10

And same for text files !!

# Specify the folder path

$folderPath = "C:\Path\To\Your\Folder"

# Get all text files in the folder

$textFiles = Get-ChildItem -Path $folderPath -Filter *.txt

# Group files by content hash

$groupedFiles = $textFiles | Group-Object { Get-Content $_.FullName | Get-Hash }

# Iterate through groups and delete duplicates

foreach ($group in $groupedFiles) {

  if ($group.Count -gt 1) {

    $group.Group | Select-Object -Skip 1 | ForEach-Object { Remove-Item $_.FullName -Force }

  }

}

Write-Host "Duplicate text files deleted successfully."

gitch10

Refined

# Specify the folder path

$folderPath = "C:\Path\To\Your\Folder"

# Get all text files in the folder

$textFiles = Get-ChildItem -Path $folderPath -Filter *.txt

# Group files by content

$groupedFiles = $textFiles | Group-Object { Get-Content $_.FullName -Raw }

# Iterate through groups and delete duplicates

foreach ($group in $groupedFiles) {

  if ($group.Count -gt 1) {

    $group.Group | Select-Object -Skip 1 | ForEach-Object { Remove-Item $_.FullName -Force }

  }

}

Write-Host "Duplicate text files deleted successfully."

gitch10

Some more import stuff with extra bits

Sub ImportData()

  Dim filePath As String

  Dim ws As Worksheet

  Dim lastRow As Long

  ' Set the file path

  filePath = "C:\Path\To\Your\File.txt" ' Update with your file path

  ' Set the worksheet where you want to import the data

  Set ws = ThisWorkbook.Sheets("Sheet1") ' Update with your sheet name

  ' Clear existing data

  ws.UsedRange.Clear

  ' Import specific columns

  With ws.QueryTables.Add(Connection:="TEXT;" & filePath, Destination:=ws.Range("A1"))

    .TextFileConsecutiveDelimiter = False

    .TextFileTabDelimiter = False

    .TextFileCommaDelimiter = False

    .TextFilePlatform = xlWindows

    .TextFileConsecutiveDelimiter = False

    .TextFileOtherDelimiter = "|"

    .Refresh

  End With

  ' Keep only specific columns (5, 6, 30, 78, 190)

  ws.Columns("A:D,E:E,AD:AD,BN:BN").Delete

  ' Remove blank rows

  On Error Resume Next

  ws.Columns("A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete

  On Error GoTo 0

  ' Remove duplicate rows

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

  ws.Range("A1:A" & lastRow).RemoveDuplicates Columns:=1, Header:=xlYes

End Sub

gitch10

Sub DeleteRowsExceptFirstBankName()

  Dim ws As Worksheet

  Dim lastRow As Long, i As Long

  ' Set the worksheet where you want to delete rows

  Set ws = ThisWorkbook.Sheets("Sheet1") ' Update with your sheet name

  ' Find the last row with data in column A

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

  ' Loop through rows starting from the second row (excluding header)

  For i = lastRow To 2 Step -1

    If ws.Cells(i, 1).Value <> "Bank Name" Then

      ' Delete the row if the value in column A is not "Bank Name"

      ws.Rows(i).Delete

    End If

  Next i

End Sub

gitch10

Sub ApplyTableToData()

  Dim ws As Worksheet

  Dim rng As Range

  Dim tbl As ListObject

  ' Set the worksheet and range containing your data

  Set ws = ThisWorkbook.Sheets("Sheet1") ' Update with your sheet name

  Set rng = ws.Range("A1:E10") ' Update with your data range

  ' Create a table

  Set tbl = ws.ListObjects.Add(xlSrcRange, rng, , xlYes)

  ' Optionally, you can customize the table properties

  tbl.TableStyle = "TableStyleMedium9" ' Update with your desired table style

  tbl.Name = "MyDataTable" ' Update with your desired table name

End Sub

gitch10

Append files using PS

$folderPath = "C:\Path\To\Your\Folder"

$outputFilePath = "C:\Path\To\Your\Output\JoinedFile.txt"

Get-ChildItem -Path $folderPath -Filter *.txt | Get-Content | Out-File -FilePath $outputFilePath

gitch10

# Set the path to the folder containing CSV files

$folderPath = "C:\Path\To\Your\Folder"

# Set the output text file path

$outputFilePath = "C:\Path\To\Your\Output\CombinedFile.txt"

# Get all CSV files in the folder

$csvFiles = Get-ChildItem -Path $folderPath -Filter *.csv

# Initialize an empty array to store content

$combinedContent = @()

# Loop through each CSV file and append its content to the array

foreach ($csvFile in $csvFiles) {

  $content = Get-Content $csvFile.FullName

  $combinedContent += $content

}

# Write the combined content to the output text file

$combinedContent | Out-File -FilePath $outputFilePath -Encoding UTF8

Write-Host "Combination complete. Output file: $outputFilePath"

gitch10

For mail retrieval

# Load Outlook COM Object

$outlook = New-Object -ComObject Outlook.Application

$namespace = $outlook.GetNamespace("MAPI")

$inbox = $namespace.GetDefaultFolder(6) # 6 corresponds to the Inbox folder

# Create a text file for storing extracted data

$outputFilePath = "C:\Path\To\Your\Output\File.txt"

# Iterate through each email in the inbox

foreach ($email in $inbox.Items) {

  # Extract body, subject, and date

  $body = $email.Body

  $subject = $email.Subject

  $date = $email.ReceivedTime

  # Append data to the text file delimited by pipe symbol

  "$body|$subject|$date" | Out-File -Append -FilePath $outputFilePath

}

# Release Outlook COM Object

[System.Runtime.Interopservices.Marshal]::ReleaseComObject($outlook) | Out-Null

gitch10

# Load Outlook COM Object

$outlook = New-Object -ComObject Outlook.Application

$namespace = $outlook.GetNamespace("MAPI")

$inbox = $namespace.GetDefaultFolder(6) # 6 corresponds to the Inbox folder

# Create a text file for storing extracted data

$outputFilePath = "C:\Path\To\Your\Output\File.txt"

# Iterate through each email in the inbox

foreach ($email in $inbox.Items) {

  # Extract body, subject, and date

  $body = $email.Body

  $subject = $email.Subject

  $date = $email.ReceivedTime

  # Append data to the text file delimited by pipe symbol

  "$body`|$subject`|$date" | Out-File -Append -FilePath $outputFilePath

}

# Release Outlook COM Object

[System.Runtime.Interopservices.Marshal]::ReleaseComObject($outlook) | Out-Null

gitch10

# Load Outlook COM Object

$outlook = New-Object -ComObject Outlook.Application

$namespace = $outlook.GetNamespace("MAPI")

$inbox = $namespace.GetDefaultFolder(6) # 6 corresponds to the Inbox folder

# Create a text file for storing extracted data

$outputFilePath = "C:\Path\To\Your\Output\File.txt"

# Iterate through each email in the inbox

foreach ($email in $inbox.Items) {

  # Extract body, subject, and date

  $body = $email.Body -replace "[\r\n]+", " " # Normalize line breaks

  $subject = $email.Subject

  $date = $email.ReceivedTime.ToString("yyyy-MM-dd HH:mm:ss") # Normalize date format

  # Append normalized data to the text file delimited by pipe symbol

  "$body|$subject|$date" | Out-File -Append -FilePath $outputFilePath

}

# Release Outlook COM Object

[System.Runtime.Interopservices.Marshal]::ReleaseComObject($outlook) | Out-Null

gitch10

# Load Outlook COM Object

$outlook = New-Object -ComObject Outlook.Application

$namespace = $outlook.GetNamespace("MAPI")

$inbox = $namespace.GetDefaultFolder(6) # 6 corresponds to the Inbox folder

# Create an array to store email data

$emailData = @()

# Iterate through each email in the inbox

foreach ($email in $inbox.Items) {

  # Extract body, subject, and date/time received

  $body = $email.Body -replace "[\r\n]+", " " # Normalize line breaks

  $subject = $email.Subject

  $dateTimeReceived = $email.ReceivedTime

  # Create an object with email data

  $emailObject = [PSCustomObject]@{

    Body = $body

    Subject = $subject

    DateTimeReceived = $dateTimeReceived

  }

  # Add the object to the array

  $emailData += $emailObject

}

# Release Outlook COM Object

[System.Runtime.Interopservices.Marshal]::ReleaseComObject($outlook) | Out-Null

# Save the array to a CSV file

$outputFilePath = "C:\Path\To\Your\Output\File.csv"

$emailData | Export-Csv -Path $outputFilePath -NoTypeInformation

Write-Host "Data saved to $outputFilePath"

gitch10

' append date and time to log file !

Function AppendDateAndTimeToLogFile()

  Dim filePath As String

  Dim logText As String

  Dim fileNumber As Integer

   

  ' Set the path to your log file

  filePath = "C:\Path\To\Your\LogFile.txt"

   

  ' Open the file for appending

  fileNumber = FreeFile

  Open filePath For Append As fileNumber

   

  ' Create the log text with current date and time

  logText = "Date and Time: " & Format(Now, "yyyy-mm-dd hh:nn:ss") & vbCrLf

   

  ' Append the log text to the file

  Print #fileNumber, logText

   

  ' Close the file

  Close fileNumber

End Function

gitch10

PS to run .bat

Start-Process -FilePath "C:\scripts\example.bat" -NoNewWindow -Wait

gitch10

PC running?

$computerName = "RemoteComputerName"

if (Test-Connection -ComputerName $computerName -Count 1 -Quiet) {

  Write-Host "$computerName is up and running."

} else {

  Write-Host "$computerName is not reachable."

}

gitch10

$computerName = "RemoteComputerName"

if (Test-Connection -ComputerName $computerName -Count 1 -Quiet) {

  Write-Host "$computerName is up and running."

} else {

  Write-Host "$computerName is not reachable. Attempting to bring it up..."

  Restart-Computer -ComputerName $computerName -Force

}

gitch10

Does file exist?

$file = "C:\Path\To\Your\File.txt"

if (Test-Path $file) {

  Write-Host "File exists. Continuing script..."

  # Add your script logic here to continue executing

} else {

  Write-Host "File does not exist. Ending script."

  # You can add any cleanup logic or exit the script here if needed

  exit

}

gitch10

Sub LookupValueAndReturnRow()

  Dim searchValue As String

  Dim lookupRange As Range

  Dim foundCell As Range

   

  ' Set the value to search for

  searchValue = "ValueToSearchFor"

   

  ' Set the range to search in (change Sheet1 to your sheet name and A:A to your column)

  Set lookupRange = Sheets("Sheet1").Columns("A:A")

   

  ' Search for the value

  Set foundCell = lookupRange.Find(What:=searchValue, LookIn:=xlValues, LookAt:=xlWhole)

   

  ' Check if value is found

  If Not foundCell Is Nothing Then

    MsgBox "Value found at row: " & foundCell.Row

  Else

    MsgBox "Value not found"

  End If

End Sub

gitch10

Sub IdentifyRowsWithSameValues()

  Dim lastRow As Long

  Dim i As Long

  Dim currentValue As Variant

  Dim rowNums As String

   

  ' Define the column you want to loop through

  Dim columnToCheck As String

  columnToCheck = "A" ' Change to your desired column

   

  ' Find the last row with data in the column

  lastRow = Cells(Rows.Count, columnToCheck).End(xlUp).Row

   

  ' Initialize rowNums to store row numbers where values are the same

  rowNums = ""

   

  ' Loop through the column

  currentValue = Cells(1, columnToCheck).Value

  For i = 2 To lastRow

    If Cells(i, columnToCheck).Value = currentValue Then

      ' If the current cell value is the same as the previous one, add its row number to rowNums

      rowNums = rowNums & ", " & i

    Else

      ' If the current cell value is different, update currentValue

      currentValue = Cells(i, columnToCheck).Value

    End If

  Next i

   

  ' Display row numbers where values are the same

  If Len(rowNums) > 0 Then

    MsgBox "Row numbers where values are the same: " & Mid(rowNums, 3)

  Else

    MsgBox "No rows found with the same values in column " & columnToCheck

  End If

End Sub

gitch10

# Set the path to your Excel workbook

$excelFilePath = "C:\Path\To\Your\Excel\File.xlsx"

# Set the name of the worksheet you want to read data from

$worksheetName = "Sheet1"

# Set the path where you want to save the CSV file

$csvFilePath = "C:\Path\To\Your\Output\File.csv"

# Create a new Excel application object

$excel = New-Object -ComObject Excel.Application

# Make Excel visible (optional)

$excel.Visible = $true

# Open the workbook

$workbook = $excel.Workbooks.Open($excelFilePath)

# Select the worksheet

$worksheet = $workbook.Worksheets.Item($worksheetName)

# Get the range of data in the worksheet

$dataRange = $worksheet.UsedRange

# Export data to CSV file

$dataRange | Export-Csv -Path $csvFilePath -NoTypeInformation

# Close the workbook without saving changes

$workbook.Close($false)

# Close Excel application

$excel.Quit()

# Release COM objects

[System.Runtime.Interopservices.Marshal]::ReleaseComObject($worksheet) | Out-Null

[System.Runtime.Interopservices.Marshal]::ReleaseComObject($workbook) | Out-Null

[System.Runtime.Interopservices.Marshal]::ReleaseComObject($excel) | Out-Null