Archiv der Kategorie: VBA

VBA: Check if string StartsWith / StartWith or EndsWith / EndWith

17. Juni 2020 Björn Karpenstein Schreibe einen Kommentar

Problem

Visual Basic for application does not have function to test, whether a string starts with or ends with another string like it is included in the .NET Framework

Approach

Those function can easily created by using the existing string functions

Solution

The following code can be pasted to a VBA project:

Public Function EndsWith(str As String, ending As String) As Boolean
     Dim endingLen As Integer
     endingLen = Len(ending)
     EndsWith = (Right(Trim(UCase(str)), endingLen) = UCase(ending))
End Function

Public Function StartsWith(str As String, start As String) As Boolean
     Dim startLen As Integer
     startLen = Len(start)
     StartsWith = (Left(Trim(UCase(str)), startLen) = UCase(start))
End Function

Example usage:

If StartsWith(„My string has something in it“, „My string“) Then Msg Box „It is in it!“
If EndsWith(„My string has something in it“, „in it“) Then Msg Box „It is in it!“

VBA

Visual Basic und VBA: Dynamische String Array / Dynamic string array in VBA

22. November 2018 Björn Karpenstein Schreibe einen Kommentar

Problem

In VBA soll ein dynamisches String-Array verwendet werden.

Solution – Lösung

Array initialisieren:

      Dim cbValuesStringArray() As String

      While i<10
        i = i + 1
        ReDim Preserve cbValuesStringArray(i - 1)
        cbValuesStringArray(i - 1) = CStr(i)
      End While

Array auslesen:

    For j = 0 To UBound(cbValuesStringArray)
        Debug.Print CStr(j) & " - " & cbValuesStringArray(j)
    Next j

VBA

Excel und VBA: Durchlaufen aller Worksheets/Tabellen in einem Workbook/einer Arbeitsmappe und exportieren in Textdatei

4. Dezember 2016 Björn Karpenstein Schreibe einen Kommentar

Problem

Es sollen alle Tabellen einer Excelmappe durchlaufen und in eine Textdatei geschrieben werden

Lösung

Sub Schaltfläche1_Klicken()
    ' Erzeugt eine Textdatei
    On Error Resume Next
    
    Dim i, j As Integer
    Dim letzteZeile As Integer
    Dim workbookName As String
    Dim artikelname As String
    Dim EANNummer As String
    Dim UmsatzVKBrutto As String
    Dim Absatz As String
    Dim VKPreisSap As String
    Dim UST As String
    
    Dim csvZeile As String
    
    Open "d:\daten\liste.txt" For Output As #1
    
    For i = 2 To ThisWorkbook.Sheets.Count - 1
        workbookName = ThisWorkbook.Sheets(i).Name
        ' Finde die letzte Zeile
        letzteZeile = Worksheets(workbookName).Cells.Find("*", [A1], , , xlByRows, xlPrevious).Row + 1
        
        For j = 1 To letzteZeile
            If Trim(ThisWorkbook.Sheets(i).Cells(j, 1)) <> "" Then
                artikelname = ThisWorkbook.Sheets(i).Cells(j, 1)
                EANNummer = ThisWorkbook.Sheets(i).Cells(j, 2)
                UmsatzVKBrutto = ThisWorkbook.Sheets(i).Cells(j, 3)
                Absatz = ThisWorkbook.Sheets(i).Cells(j, 4)
                
                If IsError(ThisWorkbook.Sheets(i).Cells(j, 5).Value) = True Then
                    VKPreisSap = "#nv"
                Else
                    VKPreisSap = CStr(ThisWorkbook.Sheets(i).Cells(j, 5))
                End If
                
                If IsError(ThisWorkbook.Sheets(i).Cells(j, 6).Value) = True Then
                    UST = "#nv"
                Else
                    UST = CStr(ThisWorkbook.Sheets(i).Cells(j, 6))
                End If
                
                csvZeile = workbookName & ";" & artikelname & ";" & EANNummer & _
                ";" & UmsatzVKBrutto & ";" & Absatz & ";" & VKPreisSap & ";" & UST
                Print #1, csvZeile
                
            End If
        Next j
    Next i
    
    Close #1

End Sub

Programmierung, VBA

Excel VBA: Kommandozeile / Command Line / DOS Parameter an Excel übergeben

17. März 2016 Björn Karpenstein Schreibe einen Kommentar

Problem

An eine Excel-Datei soll ein Kommandozeilenparameter übergeben werden, der in VBA weitergenutzt werden kann.

Ansatz – Approach

Nutzung der Kernel32.dll-Bibliothek
Deklaration von Kernel32-Funktionen
- GetCommandLineW
- lpString
- RtlMoveMemory
Erstellung einer Funktion für die Verwendeung
Beispielaufruf

Lösung – Solution

Im Modulkopf von Modul1.bas (oder auch in der Arbeitsmappe) werden Funktionen deklariert:

1.) Modulkopf (Modul1.bas): Deklaration der Kernel Funktionen für die Ausführung von Kommandozeilenparametern:

' Used at module level to declare the default 
' lower bound for array subscripts (Array starts with 0)
Option Base 0

' Erzwingt die explizite Deklaration aller 
' Variablen in einer Datei 
Option Explicit

' Deklariert die Funktionen aus kernel32.dll 
Declare Function GetCommandLine Lib "kernel32" Alias "GetCommandLineW" () As Long
Declare Function lstrlenW Lib "kernel32" (ByVal lpString As Long) As Long
Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (MyDest As Any, MySource As Any, ByVal MySize As Long)

2.) Erstellen einer einfachen Funktion, die die Ausführung von Kommandos anhand der kernel32.dll-Funktionen erlaubt.

Function CmdToSTr(Cmd As Long) As String
Dim Buffer() As Byte
Dim StrLen As Long
   If Cmd Then
      StrLen = lstrlenW(Cmd) * 2
      If StrLen Then
         ReDim Buffer(0 To (StrLen - 1)) As Byte
         CopyMemory Buffer(0), ByVal Cmd, StrLen
         CmdToSTr = Buffer
      End If
   End If
End Function

3.) Wenn das Workbook (die Arbeitsmappe) geöffnet wird, soll der Parameter (hier /cs:irgendwas ) zur Weiterverwendung genutzt werden können

Private Sub Workbook_Open()
    Dim CmdRaw As Long

    Dim CmdLine As String
    Dim start As Integer
    'The return value is a pointer to the command-line string for the current process.
    CmdRaw = GetCommandLine
    CmdLine = CmdToSTr(CmdRaw)
    
    start = InStr(CmdLine, "/cs:")
    ende = Len(CmdLine) - start - 3
    Tabelle1.Cells(1, 1) = Right(CmdLine, ende)

    mainForm.Show
End Sub

4.) Aufruf der Datei

C:\Program Files (x86)\Microsoft Office\Office12\EXCEL.exe C:\tracematrix.xlsm /cs:meinParameter

MS SQL Server, VBA

Excel VBA: Create dynamic worksheet from SQL Query / Excel Arbeitsblatt durch SQL Query erstellen

22. Juli 2015 Björn Karpenstein Schreibe einen Kommentar

Problem

A new Worksheet should be created, that contains the result of an SQL Query (ADODB) generic (in the way, that no column names have to be adressed in the recordset.

Approach – Ansatz

Iteration over the Resultsets field names to get Meta Information / Header names
Usage of CopyFromRecordSet method of the Range Object: worksheet.Range(„A2“).CopyFromRecordset Rs

Solution – Lösung

Sub CreateExcelSheetWithQueryResult(ws As Worksheet, sql As String)
    Dim Cn As New ADODB.Connection
    Dim Rs As New ADODB.Recordset
    Dim vaTmp() As String
    
    Cn.Provider = "SQLOLEDB.1"
    
    Cn.ConnectionString = "Password=pass;" & _
    "Persist Security Info=True;" & _
    "User ID=user;" & _
    "Initial Catalog=databaseName;" & _
    "Data Source=ServernameOrIP"
    
    Cn.Open
    
    Rs.CursorType = adOpenKeyset
    Rs.LockType = adLockPessimistic
    Rs.Open sql, Cn, adOpenStatic
   
    ws.Cells.Clear
    
    ' This section fills in the field names from the Orders table.
    ReDim vaTmp(Rs.Fields.Count)
    For x = 0 To Rs.Fields.Count - 1
        vaTmp(x) = Rs.Fields(x).Name
    Next
    ws.Cells(1, 1).Resize(1, Rs.Fields.Count) = vaTmp
   
    ws.Range("A2").CopyFromRecordset Rs
    
    Rs.Close
    Cn.Close
End Sub

And if you want to create a new Excel sheet you can do this with a button that assigned macro contains the following source:

Sub DetailQuery1_KlickenSieAuf()
    Dim ws As Worksheet
    Sheets.Add After:=Sheets(Sheets.Count)
    ' Referenz darauf
    Set ws = Sheets(Sheets.Count)
    CreateExcelSheetWithQueryResult ws, "SELECT TOP 10 * FROM irrsinn"
    
End Sub

VBA

Excel und VBA: Ein Sheet einlesen und kopieren

12. August 2014 Björn Karpenstein Schreibe einen Kommentar

Problem

Ein Sheet soll aus einer anderen Datei rauskopiert und hier eingelesen werden

Ansatz

Über manuelles einlesen

Lösung

Benutzter Funktion:

' Prüfen ob workbook bereits offen
Function IsWorkbookOpen(strWB As String) As Boolean
   On Error Resume Next
   IsWorkbookOpen = Not Workbooks(strWB) Is Nothing
End Function

Funktion kopiereSheet:

Sub kopiereSheet(zielDatei As String, materialnummer As String)
    Dim ZWB As Workbook
    Dim letzteZeileQuelle, letzteSpalteQuelle As Integer
    Dim QWS As Worksheet, ZWS As Worksheet

    
    ' Debug.Print ZWB.ActiveSheet.Name & "<<<< ZWB VORHER QWS >>>>" & QWS.Name
        
    If Not IsWorkbookOpen(zielDatei) Then
        Application.DisplayAlerts = False
        Workbooks.Open Tabelle1.Cells(2, 2) & zielDatei                
        Application.DisplayAlerts = True
    End If
        
    Set ZWB = Workbooks(zielDatei)                             
    Set QWS = QWB.Worksheets(materialnummer)   ' Quelle
   
    
    ZWB.Sheets.Add after:=ZWB.Worksheets(1)
    ZWB.ActiveSheet.Name = materialnummer
    
    Set ZWS = ZWB.ActiveSheet
        
    ' Finde die letzte Zeile
    letzteZeileQuelle = QWS.Cells.Find("*", [A1], , , xlByRows, xlPrevious).Row + 1
    letzteSpalteQuelle = QWS.Cells.Find("*", [A1], , , xlByRows, xlPrevious).Row + 1
               
    Dim i, j As Integer
    
    For i = 1 To letzteZeileQuelle
        For j = 1 To letzteSpalteQuelle
            ZWS.Cells(i, j) = QWS.Cells(i, j)
        Next j
    Next i
   
   Debug.Print ZWB.ActiveSheet.Name & "<<<< ZWB NACHHER QWS >>>>" & QWS.Name
  
   ZWB.Sheets(1).Activate
End Sub

VBA

Excel und VBA: Prüfen ob ein Workbook, Worksheet oder Sheet bereits geöffnet ist / Check if Workbook, Worksheet, Sheet has already been opened

12. August 2014 Björn Karpenstein Schreibe einen Kommentar

Problem

Ohne alle Sheets zu durchlaufen wird eine performante Lösung gesucht zu überprüfen, ob ein Sheet oder Workbook bereits geöffnet wurde.

Ansatz

Eine einfache Methode ist unter Benutzung der „On Error Resume Next“ Anweisung eine Prüfen nach der Referenz

Lösung

Prüfen für Workbook

' Prüfen ob workbook bereits offen
Function IsWorkbookOpen(strWB As String) As Boolean
   On Error Resume Next
   IsWorkbookOpen = Not Workbooks(strWB) Is Nothing
End Function

Beispiel:

If Not IsWorkbookOpen(pfad & zielDatei) Then
 ' Schaltet die Meldungen aus, 
 Application.DisplayAlerts = False
 Workbooks.Open pfad & zielDatei        
 ' Schaltet die Meldungen wieder ein 
 Application.DisplayAlerts = True
End If

Prüfen für Worksheet:

Dim QWB As Workbook
Set QWB = Workbooks(„JAN-MARCH.xlsx“)
If WorksheetEx(QWB, aktuelleMaterialNummer) Then…

Function WorksheetEx(WBTest As Workbook, strNam As String) As Boolean
   On Error Resume Next
   WorksheetEx = WBTest.Worksheets(strNam).Index > 0
End Function

Analog für Sheets

Sheets sind Worksheets inklusive Charts, Pivottabellen …

Function SheetEx(strNam As String) As Boolean
   On Error Resume Next
   SheetEx = Sheets(strNam).Index > 0
End Function

VBA

VBA und Excel: Dateien aus Verzeichnis einlesen / Read all files from directory

12. August 2014 Björn Karpenstein Schreibe einen Kommentar

Problem

In VBA sollen alle Dateien eines Verzeichnisses eingelesen und ausgegeben werden.

Ansatz

Über das OLE Object scripting.FileSystemObject bekommt Excel die Möglichkeit für diese Operation

Lösung

Mit dem folgenden Code lassen sich alle Dateien eines Verzeichnisses einlesen.

Sub Schaltfläche1_KlickenSieAuf()
' Hole alle Dateien vom Verzeichnis
    Dim fs As Object
    Dim fVerz As Object
    Dim fDatei As Object
    Dim fdateien As Object
    Dim strDat As String
    Dim Zeile As Integer

    Set fs = CreateObject("scripting.FileSystemObject")
    Set fVerz = fs.getFolder("C:\verzeichnis")
    
    Set fdateien = fVerz.Files

    For Each fDatei In fdateien
        If InStr(fDatei, "") &gt; 0 Then
            Zeile = Zeile + 1
            Debug.Print fDatei.Name
        End If
    Next fDatei
End Sub

VBA

Word VBA: Alle Bilder / OLE-Objekte automatisch verkleinern

24. April 2013 Björn Karpenstein 1 Kommentar

Problem

In einem Dokument sollen alle Bilder auf eine fixe Breite von 400 Bildpunkten im Seitenverhältnis verkleinert oder vergrößert werden.

Ansatz

Über das Seitenverhältnis der alten Größe der Seite A (a) zur neuen Größe der Seite A (ax) lässt sich die Aspect Ratio Verhältniszahl errechnen.
Diese Verhältniszahl kann mit der Größe der Seite B (b) des Rechteckes multipliziert werden, um die neue Größe der Seite B (bx) zu ermittlen.

Lösung

Sub bilderKleinerMachen()
    ' By Bjoern Karpenstein
    Dim s As InlineShape
    
    Dim aspectRatio As Double
    
    Dim newWidth As Integer
    
    newWidth = 400
    
    Dim i As Integer
            
    i = 1
        
    For Each s In ActiveDocument.InlineShapes
        s.Select
        If (s.Width > newWidth) Then
            If i > 1 Then
              aspectRatio = CDbl(newWidth) / CDbl(s.Width)
              s.Width = newWidth
              s.Height = CInt(s.Height * aspectRatio)
            End If
            i = i + 1
        End If
    Next
End Sub

IBM DOORS, VBA

VBA (Import Excel in Doors): In Unicode Datei schreiben (TSV Datei erstellen) / Write to unicode file (create TSV file)

28. September 2012 Björn Karpenstein Schreibe einen Kommentar

Aufgabe – Problem

Der Inhalt eines Excel-Sheets mit Unicode soll in eine Datei geschrieben werden (damit z.B. IBM Doors über File -> Importieren -> Spreadsheet den Inhalt importieren kann).

A unicode file should be written with the contents of an Excel Sheet using VBA

Vorraussetzung – Prerequirement

Im VBA Editor muss im Menü unter „Verweise“ der Punkt „Microsoft Scripting Runtime“ aktiviert werden.
In the VBA Editor a reference should be added „Microsoft Scripting Runtime“

Ansatz – Approach

(Es wird VBA Code im Excel sheet hinterlegt was den Inhalt in eine TSV-Datei, die von Doors importiert werden kann, auslagert).
Das folgende Skript zeigt ein Iterieren über ein komplettes Excel sheet und schreibt die ersten 3 Spalten in Tabulator-Separiert in eine Datei. Somit könnte man eine TSV-Datei generieren die z.B. von IBM Doors eingelesen werden kann.

Lösung – Solution

    Dim letzteZeile As Integer
    Dim i As Integer
    
    Dim ID,Col1,Col2 As String
    
    Dim fso As New FileSystemObject

    ' Declare a TextStream.
    Dim stream As TextStream

    ' Create a TextStream.
    Set stream = fso.CreateTextFile("c:\dev\wingstext.csv", True, True)
      
    ' Finde die letzte Zeile
    letzteZeile = Cells.Find("*", [A1], , , xlByRows, xlPrevious).Row + 1
               
    For i = 1 To letzteZeile
        ID = Tabelle1.Cells(i, 1)
        Col1 = Tabelle1.Cells(i, 2)
        Col2 = Tabelle1.Cells(i, 3)
        
        stream.WriteLine ID & vbTab & Col1 & vbTab & Col2

    Next i
    
    ' Close the file.
    stream.Close


Name:
Email:
Für:

Problem

Approach

Solution

Problem

Solution – Lösung

Problem

Lösung

Problem

Ansatz – Approach

Lösung – Solution

Problem

Approach – Ansatz

Solution – Lösung

Problem

Ansatz

Lösung

Problem

Ansatz

Lösung

Prüfen für Workbook

Prüfen für Worksheet:

Analog für Sheets

Problem

Ansatz

Lösung

Problem

Ansatz

Lösung

Aufgabe – Problem

Vorraussetzung – Prerequirement

Ansatz – Approach

Lösung – Solution

by Björn Karpenstein