Archiv der Kategorie: VBA

Programmierung, VBA

Microsoft Excel VBA: How to delete a worksheet in a workbook / Ein Arbeitsblatt in einer Arbeitsmappe löschen

Schreibe einen Kommentar

Problem

A worksheet within a workbook shall be deleted via VBA in Excel.
Ein Arbeitsblatt soll in einer Arbeitsmappe gelöscht werden.

Approach / Ansatz

  • Create a new SUB method with the worksheet name as parameter / Definition einer neuen Sub-Methode mit Übergabe des Namen des zu löschenden Arbeitsblattes
  • Iterate all worksheets / über alle Arbeitsblätter iterieren
    • Check the name of the current worksheet / Namen der Worksheets prüfen
      • When the name matches the SUB paramter, the worksheet will get deleted via .Delete method / Wenn der Name des übergebenen Parameters entspricht, wird das worksheet gelöscht mit der .Delete Methode

Solution / Lösung

Sub DeleteWorksheet(worksheetName As String)
Dim ws As Worksheet, wb As Workbook

Set wb = ActiveWorkbook

Application.DisplayAlerts = False

For Each ws In wb.Worksheets
    If ws.Name = worksheetName Then
        ws.Delete
        Exit For
    End If
Next

Application.DisplayAlerts = True

End Sub

Programmierung, VBA

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

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

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

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

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:

Modulkopf

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

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

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

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

1 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

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