31.10.2012

Datei oder Ordner vorhanden - Internet...

Frage: In Spalte A habe ich eine Liste von Dateilinks z. B.
"http://vbanet.blogspot.de/2012/10/range-als-pdf-speichern-mit.html"
bzw. auch Ordner
"http://vbanet.blogspot.de/2012/10/".
Jetzt hätte ich gerne in Spalte B stehen, ob die Dateien bzw. Ordner vorhanden sind, oder nicht. Wie geht das?

Hier noch eine Beispieldatei: Datei oder Ordner vorhanden - Internet...

Option Explicit
'-------------------------------------------------------------------------- 
' Module    : Modul1 
' Procedure : Main 
' Author    : Case (Ralf Stolzenburg) 
' Date      : 31.10.2012 
' Purpose   : Datei oder Ordner vorhanden - Internet... 
'-------------------------------------------------------------------------- 
Public Sub Main()
    Call CheckRange(Tabelle1.Range("A1:A12"))
End Sub
Private Sub CheckRange(ByVal rngRange As Range)
    Dim objXML As Object
    Dim rngCell As Range
    On Error GoTo Fin
    Set objXML = CreateObject("Microsoft.XMLHTTP")
    For Each rngCell In rngRange
        On Error Resume Next
        With objXML
            .Open "GET", Tabelle1.Cells _
                (rngCell.Row, rngCell.Column).Text, False
            .Send
            If Not .ReadyState = 4 Then
                Tabelle1.Cells(rngCell.Row, _
                    rngCell.Column + 1).Value = "Adresse nicht lesbar"
            Else
                Tabelle1.Cells(rngCell.Row, _
                    rngCell.Column + 1).Value = .StatusText
            End If
        End With
        Err.Clear
        On Error GoTo Fin
    Next rngCell
Fin:
    Set objXML = Nothing
    If Err.Number <> 0 Then MsgBox "Error: " & _
        Err.Number & " " & Err.Description
End Sub

Range als PDF speichern mit Auswahldialog...

Frage: Zwei Dinge. Einmal kann ein Range in ein PDF gespeichert werden. Mit Auswahldialog zum speichern (Das ist in "Private Sub CommandButton1_Click()" gelöst). Die PDF - Datei soll dann angezeigt werden.

Dann wird es aber schwieriger. Die PDF - Datei soll erst 5 Sekunden angezeigt werden, dann soll die Nachfrage kommen, ob gespeichert werden soll, oder nicht. Bei Nein wird die temporäre Datei (ist im Tempordner) vom PC gelöscht. Bei Ja kommt der Speicherdialog. Das ist in "Private Sub CommandButton2_Click()" gelöst.

Hier noch eine Beispieldatei: Range als PDF speichern mit Auswahldialog...

Code in das Klassenmodul der Tabelle in der die CommandButton sind:

Option Explicit
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
    (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function SetForegroundWindow Lib "user32" _
    (ByVal hwnd As Long) As Long
'-------------------------------------------------------------------------- 
' Module    : Tabelle1 
' Procedure : CommandButton1_Click 
' Author    : Case (Ralf Stolzenburg) 
' Date      : 31.10.2012 
' Purpose   : Range als PDF speichern mit Auswahldialog... 
'-------------------------------------------------------------------------- 
Private Sub CommandButton1_Click()
    Dim varPath As Variant
    Dim RngRange As Range
    On Error GoTo Fin
    Set RngRange = Union(Range("B6:G46"), Range("B49:G89"), _
        Range("B91:G132"), Range("B135:G175"))
    varPath = Application.GetSaveAsFilename( _
        InitialFileName:=ThisWorkbook.Path & "\" & ActiveSheet.Name, _
        FileFilter:="PDF(*.pdf), *.pdf", _
        Title:="Speichern als PDF")
    If Not varPath = False Then
        RngRange.ExportAsFixedFormat 0, varPath, , , , , , True
    Else
        MsgBox "Abbrechen geklickt..."
    End If
Fin:
    Set RngRange = Nothing
    If Err.Number <> 0 Then MsgBox "Error: " & _
        Err.Number & " " & Err.Description
End Sub
'-------------------------------------------------------------------------- 
' Module    : Tabelle1 
' Procedure : CommandButton2_Click 
' Author    : Case (Ralf Stolzenburg) 
' Date      : 31.10.2012 
' Purpose   : PDF erst anzeigen, dann Nachfrage - Ja PDF speichern, 
'             bei Nein PDF schliessen und temporäre Datei löschen... 
'-------------------------------------------------------------------------- 
Private Sub CommandButton2_Click()
    Dim varPath As Variant
    Dim RngRange As Range
    On Error GoTo Fin
    Set RngRange = Union(Range("B6:G46"), Range("B49:G89"), _
        Range("B91:G132"), Range("B135:G175"))
    RngRange.ExportAsFixedFormat 0, Environ$("TMP") & "\TMPpdf", , , , , , True
    Application.Wait Now + TimeSerial(0, 0, 5)
    SetForegroundWindow (FindWindow("xlMain", vbNullString))
    Select Case MsgBox("PDF speichern?", 4 Or 32 Or 0, "PDF")
        Case vbYes
            varPath = Application.GetSaveAsFilename( _
                InitialFileName:=ThisWorkbook.Path & "\" & ActiveSheet.Name, _
                FileFilter:="PDF(*.pdf), *.pdf", _
                Title:="Speichern als PDF")
                If Not varPath = False Then
                    RngRange.ExportAsFixedFormat 0, varPath
                End If
                Call PDFClose("TMPpdf.pdf")
        Case vbNo
            Call PDFClose("TMPpdf.pdf")
            Application.Wait Now + TimeSerial(0, 0, 1)
            Kill (Environ$("TMP") & "\TMPpdf.pdf")
    End Select
Fin:
    Set RngRange = Nothing
    If Err.Number <> 0 Then MsgBox "Error: " & _
        Err.Number & " " & Err.Description
End Sub

Code in ein allgemeines Modul:

Option Explicit
Private Declare Function FindWindow Lib "user32" _
    Alias "FindWindowA" (ByVal lpClassName As String, _
    ByVal lpWindowName As String) As Long
Private Declare Function PostMessage Lib "user32" _
    Alias "PostMessageA" (ByVal hwnd As Long, _
    ByVal wMsg As Long, ByVal wParam As Long, _
    ByVal lParam As Long) As Long
Private Declare Function OpenProcess Lib "kernel32" _
    (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, _
    ByVal dwProcessId As Long) As Long
Private Declare Function GetWindowThreadProcessId Lib "user32" _
    (ByVal hwnd As Long, lpdwProcessId As Long) As Long
Declare Function GetParent Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" _
    (ByVal hwnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
Private Declare Function GetWindow Lib "user32" (ByVal hwnd As Long, _
    ByVal wCmd As Long) As Long
Const GW_HWNDNEXT = 2
Const WM_CLOSE = &H10
Const SYNCHRONIZE = &H100000
'-------------------------------------------------------------------------- 
' Module    : Modul1 
' Procedure : PDFClose 
' Author    : Case (Ralf Stolzenburg) 
' Date      : 31.10.2012 
' Purpose   : PDF - Datei schliessen... 
' Quelle    : http://support.microsoft.com/kb/147659/en-us/ 
'-------------------------------------------------------------------------- 
Public Sub PDFClose(ByVal strTMP As String)
    Dim hWindow As Long
    Dim hProcess As Long
    Dim lProcessId As Long
    Dim lngReturnValue As Long
    hWindow = SearchHndByWndName_Parent(strTMP)
    hProcess = OpenProcess(SYNCHRONIZE, 0&, lProcessId)
    lngReturnValue = PostMessage(hWindow, WM_CLOSE, 0&, 0&)
End Sub
Private Function SearchHndByWndName_Parent(strSearch As String) As Long
    Dim strTMP As String * 100
    Dim nhWnd As Long
    nhWnd = FindWindow(vbNullString, vbNullString)
    Do While Not nhWnd = 0
        If GetParent(nhWnd) = 0 Then
            GetWindowText nhWnd, strTMP, 100
            If InStr(strTMP, strSearch) > 0 Then
                SearchHndByWndName_Parent = nhWnd
                Exit Do
            End If
        End If
        nhWnd = GetWindow(nhWnd, GW_HWNDNEXT)
    Loop
End Function

30.10.2012

Viele Tabellenblätter - Viele Zellen - Gesamtübersicht

Frage: Aus sehr vielen Tabellenblättern sollen sehr viele Zellen in ein neu zu erstellendes Tabellenblatt gebracht werden. Die Zellen sind "A2, B11, G11, M11, B19, G19, M19, B28, G28, M28, B34, G34, M34, B41, G41, M41". Wie geht das?

Ein neues Tabellenblatt wird erstellt und bekommt den Namen "Gesamt".

Hier noch eine Beispieldatei mit 160 Tabellenblätter:
Viele Tabellenblätter - Viele Zellen - Gesamtübersicht... [ZIP 6 MB]

Option Explicit
'-------------------------------------------------------------------------- 
' Module    : Modul1 
' Procedure : Main 
' Author    : Case (Ralf Stolzenburg) 
' Date      : 30.10.2012 
' Purpose   : Array - Viele Tabellenblätter - Zellen - Gesamtübersicht 
'-------------------------------------------------------------------------- 
Public Sub Main()
    ' Variablendeklaration 
    Dim wksSheetAll As Worksheet
    Dim wksSheet As Worksheet
    Dim varArr() As Variant
    Dim intCount As Integer
    Dim strCells As String
    Dim lngLastRow As Long
    Dim intCalc As Integer
    Dim rngRange As Range
    Dim lngCount As Long
    On Error GoTo Fin
    ' Die Applikation ruhig stellen 
    With Application
        .ScreenUpdating = False
        .AskToUpdateLinks = False
        .EnableEvents = False
        intCalc = .Calculation
        .Calculation = xlCalculationManual
        .DisplayAlerts = False
    End With
    ' Das Array grösser als der zu erwartende Inhalt dimensionieren 
    ' Damit sparen wir uns ein "ReDim Preserve" IN der For-Schleife 
    Redim varArr(10000)
    ' Neues Tabellenblatt erstellen 
    Set wksSheetAll = ThisWorkbook.Worksheets.Add
    ' Neues Tabellenblatt an den Anfang stellen 
    wksSheetAll.Move Before:=ThisWorkbook.Worksheets(1)
    ' Neues Tabellenblatt bekommt den Mamen "Gesamt" 
    wksSheetAll.Name = "Gesamt"
    ' Die auszulesenden Zellen der jeweiligen Tabellenblätter 
    strCells = "A2,B11,G11,M11,B19,G19,M19,B28,G28,M28,B34,G34,M34,B41,G41,M41"
    ' Für jedes Tabellenblatt in der Mappe in der das Makro gestartet wurde 
    For Each wksSheet In ThisWorkbook.Worksheets
        ' Beginne mit Tabellenblatt ab der 2ten Stelle 
        If wksSheet.Index > 1 Then
            ' Beziehe dich auf dieses Blatt 
            With wksSheet
                ' Jede Zelle der Variablen strCells wird berücksichtigt 
                For Each rngRange In .Range(strCells)
                    ' Letzte belegte Zelle Spalte F und PLUS 1 
                    lngLastRow = IIf(IsEmpty(wksSheetAll.Cells _
                        (wksSheetAll.Rows.Count, 1)), wksSheetAll.Cells _
                        (wksSheetAll.Rows.Count, 1).End(xlUp).Row, _
                        wksSheetAll.Rows.Count) + 1
                    ' Array befüllen 
                    varArr(lngCount) = rngRange.Value
                    ' Laufvariable hochsetzen 
                    lngCount = lngCount + 1
                Next rngRange
            End With
            ' Array wird auf die tatsächliche Grösse reduziert 
            Redim Preserve varArr(lngCount)
            ' Daten in Tabelle "Gesamt" aus Array eintragen 
            wksSheetAll.Cells(lngLastRow, intCount + 1).Resize _
                (, Ubound(varArr)) = varArr
            ' Laufvariable für nächsten Durchlauf zurück setzen 
            lngCount = 0
        End If
    Next wksSheet
Fin:
    ' Objektvariable leeren 
    Set wksSheetAll = Nothing
    With Application
        ' Die Applikation aufwecken 
        .ScreenUpdating = True
        .AskToUpdateLinks = True
        .EnableEvents = True
        .Calculation = intCalc
        .DisplayAlerts = True
    End With
    If Err.Number <> 0 Then MsgBox "Error: " & _
        Err.Number & " " & Err.Description
End Sub

26.10.2012

Excel -> Word in Textmarken (Bookmarks)...

Frage: In meiner Exceltabelle habe ich verschiedene Zellen, deren Inhalt in eine bestehende Worddatei mit vorhandenen Textmarken (Bookmarks) eingefügt werden soll. Kann auch ein Bereich als Bild gespeichert werden? Oder auch einfach rüberkopiert werden? Dann noch ein Speicherndialog?

In der gezippten Beispieldatei ist ein Exceldokument und zwei Worddokumente. Die Worddokumente sind identisch - eines nur als Sicherung.

Hier noch eine Beispieldatei: Daten von Excel nach Word in Textmarken (Bookmarks)...

Option Explicit
' Namen der Textmarken im Worddokument 
Const strBookmark1 As String = "Name"
Const strBookmark2 As String = "Strasse"
Const strBookmark3 As String = "PLZ"
Const strBookmark4 As String = "Ort"
Const strBookmark5 As String = "Betreff"
Const strBookmark6 As String = "Wertetabelle"
Const strBookmark7 As String = "Wertetabelle1"
' Konstante für den Speichern-Unter Dialog in Word 
Const wdDialogFileSaveAs = 84
' Wenn Word nicht offen ist wird diese Variable auf True 
' gesetzt und Word am Ende wieder geschlossen 
' War Word schon offen, belibt es das auch 
Dim blnTMP As Boolean
'-------------------------------------------------------------------------- 
' Module    : Modul1 
' Procedure : Main 
' Author    : Case (Ralf Stolzenburg) 
' Date      : 26.10.2012 
' Purpose   : Daten von Excel nach Word in Textmarken (Bookmarks)... 
'-------------------------------------------------------------------------- 
Public Sub Main()
    ' Variablendeklaration 
    ' Da wir mit Late Binding arbeiten, also ohen Verweise auf die 
    ' Wordbibliothek dimensionieren wir die Wordbezogenen Variablen 
    ' als Objekt, die dann mit Set dem entsprechenden 
    ' Objekt zugewiesen werden 
    Dim objWordRange As Object
    Dim objDocument As Object
    Dim objDialog As Object
    Dim objApp As Object
    Dim strDoc As String
    ' Bei einem Fehler gehe zu diesrr Sprungmarke 
    On Error GoTo Fin
    ' Das Worddokument mit Pfad und Name 
    strDoc = ThisWorkbook.Path & _
        Application.PathSeparator & "Lieferschein.doc"
    ' Die Wordapplikation wird mit der Funktion "OffApp" gesucht 
    ' ODER bei Bedarf gestartet 
    Set objApp = OffApp("Word")
    'folgende Codezeile für Word nicht sichtbar 
    'Set objApp = OffApp("Word", False) 
    ' Wenn die Word der Objektvariablen zugewiesen werden konnte dann... 
    If Not objApp Is Nothing Then
    ' Öffne das Worddokument, zugewiesen an die Objektvariable objDocument 
    Set objDocument = objApp.Documents.Open(Filename:=strDoc)
    ' With für Schreibfaule :-) Alle Bezüge auf Tabelle1 müssen 
    ' mit einem Punkt beginnen 
    With ThisWorkbook.Worksheets("Tabelle1")
        ' Prüfe, ob die Textmarke vorhanden ist 
        If objDocument.Bookmarks.Exists(strBookmark1) = True Then
            ' Schreibe den Wert von B2 in die Textmarke Name 
            objDocument.Bookmarks(strBookmark1).Range = .Range("B2").Text
        End If
        If objDocument.Bookmarks.Exists(strBookmark2) = True Then
            objDocument.Bookmarks(strBookmark2).Range = .Range("C2").Text
        End If
        If objDocument.Bookmarks.Exists(strBookmark3) = True Then
            objDocument.Bookmarks(strBookmark3).Range = .Range("D2").Text
        End If
        If objDocument.Bookmarks.Exists(strBookmark4) = True Then
            objDocument.Bookmarks(strBookmark4).Range = .Range("E2").Text
        End If
        If objDocument.Bookmarks.Exists(strBookmark5) = True Then
            objDocument.Bookmarks(strBookmark5).Range = .Range("F2").Text
        End If
        ' Kopiere einen Bereich als Bild an die Textmarke Wertetabelle 
        ' Objektvariable objWordRange leeren 
        If objDocument.Bookmarks.Exists(strBookmark6) = True Then
            .Range("H1:J4").CopyPicture 1, 2
            Set objWordRange = objDocument.Bookmarks(strBookmark6).Range
            objWordRange.Paste
            Set objWordRange = Nothing
        End If
        ' Kopiere einen Bereich an die Textmarke Wertetabelle1 
        If objDocument.Bookmarks.Exists(strBookmark7) = True Then
            .Range("H1:J4").Copy
            Set objWordRange = objDocument.Bookmarks(strBookmark7).Range
            objWordRange.Paste
        End If
        ' Ameisenrennen um den kopierten Bereich beenden 
        ' und Zwischenspeicher leeren 
        Application.CutCopyMode = True
        ' Objektvariable objWordRange leeren 
        Set objWordRange = Nothing
        ' Word Speicherdialog aufrufen 
        Set objDialog = objApp.Dialogs(wdDialogFileSaveAs)
        With objDialog
            ' Pfad vorgeben 
            .Name = "C:\Temp\"
            ' Wenn auf Speichern geklickt wurde... 
            If .Display = -1 Then
                objDocument.SaveAs Filename:=.Name
            End If
            ' Dokument schliessen 
            objDocument.Close
        End With
    End With
    Else
        ' Ausgabe, wenn die Objektvariable objApp Nothing ist... 
        MsgBox "Applikation nicht installiert!"
    End If
Fin:
    If Not objApp Is Nothing Then
        ' Wor war nicht offen, also... 
        If blnTMP = True Then
            ' ... Word schliessen 
            objApp.Quit
            blnTMP = False
        End If
    End If
    ' Objektvariablen leeren 
    Set objWordRange = Nothing
    Set objDocument = Nothing
    Set objApp = Nothing
    Application.CutCopyMode = True
    ' Wenn die Fehlernummer NICHT 0 ist, dann gib die Fehlernummer 
    ' und die Fehlerbeschreibung aus 
    If Err.Number <> 0 Then MsgBox "Fehler: " & _
        Err.Number & " " & Err.Description
End Sub
Private Function OffApp(ByVal strApp As String, _
    Optional blnVisible As Boolean = True) As Object
    Dim objApp As Object
    On Error Resume Next
    Set objApp = GetObject(, strApp & ".Application")
    Select Case Err.Number
        Case 429
            Err.Clear
            Set objApp = CreateObject(strApp & ".Application")
            blnTMP = True
            If blnVisible = True Then
                On Error Resume Next
                objApp.Visible = True
                Err.Clear
            End If
    End Select
    On Error GoTo 0
    Set OffApp = objApp
    Set objApp = Nothing
End Function

24.10.2012

Alle Tabellenblätter - Druckbereich - neue Datei...

Frage: In meiner Datei habe ich viele Tabellenblätter die alle gleich aufgebaut sind. Alle bis auf das letzte Blatt (das ist eine Zusammenfassung) haben einen Druckbereich. Da in den anderen Bereichen sensible Daten stehen möchte ich von allen Tabellenblättern nur den Druckbereich in eine neue Datei kopieren. Jeweils auch in ein eigenes Blatt - welches den gleichen Namen wie das Ursprungstabellenblatt haben soll. Es sind auch Formeln vorhanden - diese sollen im neuen Tabellenblatt nicht mehr vorhanden sein. Am Schluss soll ein Speicherdialog aufgerufen werden mit vorgeschlagenem Verzeichnis (das gleiche wie die Originaldatei) und einem Namen mit Zusatz vom aktuellen Datum plus Uhrzeit - wie geht das?

Hier noch eine Beispieldatei: Alle Tabellenblaetter - Druckbereich - neue Datei...

Option Explicit
Const strTMP As String = "backup"
'-------------------------------------------------------------------------- 
' Module    : Modul1 
' Procedure : Main 
' Author    : Case (Ralf Stolzenburg) 
' Date      : 24.10.2012 
' Purpose   : Alle Tabellenblaetter - Druckbereich - neue Datei... 
'-------------------------------------------------------------------------- 
Sub Main()
    Dim wkbBook As Workbook
    Dim intTMP As Integer
    On Error GoTo Fin
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
    End With
    Workbooks.Add -4167
    Set wkbBook = ActiveWorkbook
    With wkbBook
        .Worksheets.Add After:=.Worksheets(.Worksheets.Count), _
            Count:=ThisWorkbook.Worksheets.Count - 2
    End With
    For intTMP = 1 To ThisWorkbook.Worksheets.Count
        If ThisWorkbook.Worksheets(intTMP).PageSetup.PrintArea <> "" Then
            With ThisWorkbook.Worksheets(intTMP)
                .Range(.PageSetup.PrintArea).Copy
            End With
            wkbBook.Worksheets(intTMP).Name = _
                ThisWorkbook.Worksheets(intTMP).Name
            With wkbBook.Worksheets(intTMP).Range("A1")
                .PasteSpecial 8
                .PasteSpecial -4163
                .PasteSpecial -4122
            End With
            With wkbBook.Worksheets(intTMP).UsedRange
                .Value = .Value
            End With
            With Application
                .Goto wkbBook.Worksheets(intTMP).Range("A1"), True
                .CutCopyMode = True
            End With
        End If
    Next intTMP
    With Application
        .Goto wkbBook.Worksheets(1).Range("A1"), True
        .Dialogs(xlDialogSaveAs).Show ThisWorkbook.Path & _
            "\" & strTMP & "_" & Format(Now, "dd_mm_yyyy_hh_mm_ss")
    End With
    wkbBook.Close False
Fin:
    Set wkbBook = Nothing
    With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
        .CutCopyMode = True
    End With
    If Err.Number <> 0 Then MsgBox "Error: " & _
        Err.Number & " " & Err.Description
End Sub

16.10.2012

Shape - AddConnector - Verbindung - Code...

Frage: Kann mir mal jemand grundsätzlich die Vorgehensweise beim einfügen von "Connectoren" per VBA aufzeigen? Und wie kann ich zwei "Shapes" mit einem Connector verbinden?

Dann würde mich noch interessieren, wie ich ein Makro auslösen kann, wenn ich auf einen der erstellten "Connectoren" klicke?

Hier noch eine Beispieldatei: Shape - AddConnector - Verbindung...

Option Explicit
Const lngColumn As Long = 5
Const lngRow As Long = 4
'-------------------------------------------------------------------------- 
' Module    : Module1 
' Procedure : Main 
' Author    : Case (Ralf Stolzenburg) 
' Date      : 16.10.2012 
' Purpose   : Shapes.AddConnector Beispiel MIT Code bei Klick auf Linie... 
'-------------------------------------------------------------------------- 
Sub Main()
    Dim wksSheet As Worksheet
    Dim intCount As Integer
    Dim shpObject As Shape
    On Error GoTo Fin
    Set wksSheet = ThisWorkbook.Worksheets("Sheet1")
    For Each shpObject In wksSheet.Shapes
        If shpObject.TopLeftCell.Column = lngColumn Then shpObject.Delete
    Next shpObject
    For intCount = 1 To 3
        Set shpObject = wksSheet.Shapes.AddConnector _
            (intCount, 20, 20, 200, 120)
        With shpObject
            .Top = wksSheet.Cells(lngRow, lngColumn).Top
            .Left = wksSheet.Cells(lngRow, lngColumn).Left
            .OnAction = "Test"
            .Line.Weight = 3
            .Name = wksSheet.Range("A1").Value & intCount
        End With
        Set shpObject = Nothing
    Next intCount
Fin:
    Set shpObject = Nothing
    Set wksSheet = Nothing
    If Err.Number <> 0 Then MsgBox "Error: " & _
        Err.Number & " " & Err.Description
End Sub
'-------------------------------------------------------------------------- 
' Module    : Module1 
' Procedure : Main_1 
' Author    : Case (Ralf Stolzenburg) 
' Date      : 16.10.2012 
' Purpose   : Button 1 und Button 2 werden verbunden... 
'-------------------------------------------------------------------------- 
Sub Main_1()
    Dim wksSheet As Worksheet
    Dim shpObject As Shape
    Set wksSheet = ThisWorkbook.Worksheets("Sheet1")
    On Error Resume Next
    wksSheet.Shapes("Connector").Delete
    Err.Clear
    On Error GoTo Fin
    Set shpObject = wksSheet.Shapes.AddConnector _
        (msoConnectorCurve, 20, 20, 200, 120)
    With shpObject.ConnectorFormat
        .BeginConnect wksSheet.Shapes("Button 1"), 1
        .EndConnect wksSheet.Shapes("Button 2"), 1
        shpObject.RerouteConnections
        shpObject.Line.Weight = 2
        shpObject.Name = "Connector"
    End With
Fin:
    Set shpObject = Nothing
    Set wksSheet = Nothing
    If Err.Number <> 0 Then MsgBox "Error: " & _
        Err.Number & " " & Err.Description
End Sub
'-------------------------------------------------------------------------- 
' Module    : Module1 
' Procedure : Test 
' Author    : Case (Ralf Stolzenburg) 
' Date      : 16.10.2012 
' Purpose   : Dieser Code wird ausgeführt, wenn auf eine der 
'             erstellten Linien geklickt wird... 
'-------------------------------------------------------------------------- 
Private Sub Test()
    Select Case ThisWorkbook.Worksheets("Sheet1"). _
        Shapes(Application.Caller).Name
        Case "Line1"
            MsgBox "I'm Line1"
        Case "Line2"
            MsgBox "I'm Line2"
        Case "Line3"
            MsgBox "I'm Line3"
        Case Else
        
    End Select
End Sub
'msoConnectorCurve = 3 = Curved connector 
'msoConnectorElbow = 2 = Elbow connector 
'msoConnectorStraight = 1 = Straight line connector 

15.10.2012

Klick Zelle - gehe zu anderer Tabelle richtige Zelle

Frage: In Sheet1 habe ich in Spalte L Namen stehen. Klicke ich einen Namen an, soll zu Sheet2 in Spalte A in die entsprechende Zelle gesprungen werden. Wie geht das?

Hier noch eine Beispieldatei: Worksheet_SelectionChange - Klick - Zelle andere Tabelle...

Option Explicit
'-------------------------------------------------------------------------- 
' Module    : Sheet1 
' Procedure : Worksheet_SelectionChange 
' Author    : Case (Ralf Stolzenburg) 
' Date      : 15.10.2012 
' Purpose   : Klick Zelle - gehe zu anderer Tabelle richtige Zelle... 
'-------------------------------------------------------------------------- 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim varRow As Variant
    If Not Intersect(Target, Columns(12)) Is Nothing Then
        If Not Target.Count > 1 Then
            With ThisWorkbook.Worksheets("Sheet2")
                varRow = Application.Match(Target.Value, .Columns(1), 0)
                If Not IsError(varRow) Then _
                    Application.Goto .Cells(varRow, 1), True
            End With
        End If
    End If
End Sub

Outlook - Ordner unter Posteingang erstellen...

Frage: Ich möchte aus Excel per VBA einen Ordner in Outlook unter "Posteingang" erstellen. Wie geht das?

Option Explicit
'-------------------------------------------------------------------------- 
' Module    : Module1 
' Procedure : Main 
' Author    : Case (Ralf Stolzenburg) 
' Date      : 15.10.2012 
' Purpose   : Outlook - Ordner unter "Posteingang" erstellen... 
'-------------------------------------------------------------------------- 
Sub Main()
    Dim objNewFolder As Object
    Dim objFolder As Object
    Dim objOutApp As Object
    Dim objName As Object
    On Error GoTo Fin
    Set objOutApp = CreateObject("Outlook.Application")
    Set objName = objOutApp.GetNamespace("MAPI")
    ' 6 = olFolderInbox 
    Set objFolder = objName.GetDefaultFolder(6)
    Set objNewFolder = objFolder.Folders.Add("Test")
Fin:
    If Err.Number <> 0 Then MsgBox "Fehler: " & _
        Err.Number & " " & Err.Description
    Set objNewFolder = Nothing
    Set objFolder = Nothing
    Set objName = Nothing
    Set objOutApp = Nothing
End Sub

10.10.2012

Geschlossene Dateien bestimmte Zellen auslesen

Frage: In eine Masterdatei sollen der Inhalt von 4 bestimmten Zellen aus allen Dateien eines Ordners (Optional mit Unterordner) eingelesen werden. Der Pfad- und Dateiname soll in der ersten Spalte als Kommentar eingefügt werden. Wie geht das?

Hier noch eine Beispieldatei: Geschlossene Dateien bestimmte Zellen auslesen...

Option Explicit
Const strSheetQ As String = "Sheet1" ' Die Tabelle wird ausgelesen 
Const strSheetZ As String = "Total" ' Die Tabelle ist in DIESER Datei 
Const strCellQ1 As String = "A1" ' Die Zelle wird ausgelesen 
Const strCellQ2 As String = "A5" ' Die Zelle wird ausgelesen 
Const strCellQ3 As String = "B8" ' Die Zelle wird ausgelesen 
Const strCellQ4 As String = "C20" ' Die Zelle wird ausgelesen 
'-------------------------------------------------------------------------- 
' Module    : Module1 
' Procedure : Files_Read 
' Author    : Case (Ralf Stolzenburg) 
' Date      : 10.10.2012 
' Purpose   : Geschlossene Dateien bestimmte Zellen auslesen... 
'-------------------------------------------------------------------------- 
Public Sub Files_Read()
    Dim intCalc As Integer
    Dim strDir As String
    Dim objFSO As Object
    Dim objDir As Object
    On Error GoTo Fin
    ' Die Application wird "stillgelegt" 
    With Application
        .ScreenUpdating = False
        .AskToUpdateLinks = False
        .EnableEvents = False
        intCalc = .Calculation
        .Calculation = xlCalculationManual
        .DisplayAlerts = False
    End With
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    ' Datei im gleichen Ordner wie Auswertungsdateien 
    ' strDir = ThisWorkbook.Path & "\" 
    ' Fester Ordner vorgegeben 
    strDir = "C:\Temp\Test\"
    strDir = IIf(Right(strDir, 1) <> "\", strDir & "\", strDir)
    Set objDir = objFSO.getfolder(strDir)
    With ThisWorkbook.Worksheets(strSheetZ)
        ' Ab Zeile 4 abwärts wir alles gelöscht 
        .Rows("2:" & .Rows.Count).ClearContents
        'dirInfo objDir, "*.xls*", True ' Mit Unterordner 
        dirInfo objDir, "*.xls*" ' Ohne Unterordner 
        ' Formeln in Werte umwandeln 
        .UsedRange.Value = .UsedRange.Value
    End With
Fin:
    ' Die Application wird wieder zum Leben erweckt 
    With Application
        .ScreenUpdating = True
        .AskToUpdateLinks = True
        .EnableEvents = True
        .Calculation = intCalc
        .DisplayAlerts = True
    End With
    ' Objektvariable(n) leeren 
    Set objDir = Nothing
    Set objFSO = Nothing
    ' Etwaig auftretende Fehler ausgeben 
    If Err.Number <> 0 Then MsgBox "Error: " & _
        Err.Number & " " & Err.Description
End Sub
Public Sub dirInfo(ByVal objCurrentDir As Object, ByVal strName As String, _
    Optional ByVal blnTMP As Boolean = False)
    Dim strFormula As String
    Dim lngLastRow As Long
    Dim varTMP As Variant
    For Each varTMP In objCurrentDir.Files
        ' Dateiname ist im Bereich der übergebenen Variablen "strName" 
        ' UND entspricht nicht dem Namen DIESER Datei 
        ' falls diese im gleichen Ordner ist 
        If varTMP.Name Like strName And varTMP.Name <> ThisWorkbook.Name Then
            ' Auch TEMPORÄRE Dateien werden ausgeschlossen 
            ' Diese beginnen in der Regel mit einer Tilde 
            If Not Left(varTMP.Name, 1) = "~" Then
                With ThisWorkbook.Worksheets(strSheetZ)
                    ' Letzte belegte Zeile ermitteln, dann + 1 
                    lngLastRow = IIf(Len(.Cells(.Rows.Count, 1)), _
                        .Rows.Count, .Cells(.Rows.Count, 1).End(xlUp).Row) + 1
                    ' Formel in lngLastRow Spalte A  reinschreiben 
                    With .Cells(lngLastRow, 1)
                        .Formula = "='" & Mid(varTMP.Path, 1, _
                            InStrRev(varTMP.Path, "\")) & "[" & _
                            Mid(varTMP.Path, InStrRev(varTMP.Path, "\") + 1) & _
                            "]" & strSheetQ & "'!" & strCellQ1
                        .ClearComments
                        .AddComment
                        .Comment.Visible = False
                        .Comment.Text Text:=varTMP.Path
                    End With
                    ' Formel in lngLastRow Spalte B  reinschreiben 
                    With .Cells(lngLastRow, 2)
                        .Formula = "='" & Mid(varTMP.Path, 1, _
                            InStrRev(varTMP.Path, "\")) & "[" & _
                            Mid(varTMP.Path, InStrRev(varTMP.Path, "\") + 1) & _
                            "]" & strSheetQ & "'!" & strCellQ2
                    End With
                    ' Formel in lngLastRow Spalte C  reinschreiben 
                    With .Cells(lngLastRow, 3)
                        .Formula = "='" & Mid(varTMP.Path, 1, _
                            InStrRev(varTMP.Path, "\")) & "[" & _
                            Mid(varTMP.Path, InStrRev(varTMP.Path, "\") + 1) & _
                            "]" & strSheetQ & "'!" & strCellQ3
                    End With
                    ' Formel in lngLastRow Spalte D  reinschreiben 
                    With .Cells(lngLastRow, 4)
                        .Formula = "='" & Mid(varTMP.Path, 1, _
                            InStrRev(varTMP.Path, "\")) & "[" & _
                            Mid(varTMP.Path, InStrRev(varTMP.Path, "\") + 1) & _
                            "]" & strSheetQ & "'!" & strCellQ4
                    End With
                End With
            End If
        End If
    Next varTMP
    ' Je nach Angabe oben werden hier auch Unterordner durchsucht 
    If blnTMP = True Then
        For Each varTMP In objCurrentDir.SubFolders
            dirInfo varTMP, strName, blnTMP
        Next varTMP
    End If
End Sub

08.10.2012

Ein Tabellenblatt für jeden Tag des Jahres...

Frage: Ich habe eine Datei mit einem Tabellenblatt. In A1 steht "01.01.2013". Nun soll für jeden Tag des Jahres ein Tabellenblatt erstellt werden. Schaltjahr soll berücksichtigt werden. Der Name des Tabellenblattes und der Inhalt von jeweils A1 ist das Datum des entsprechenden Tages. Wie geht das?

ACHTUNG: Bitte berücksichtigen:
Hinweis - Workaround...

Hier noch eine Beispieldatei: Tabellenblatt - jeder Tag - Jahr...

Option Explicit
'-------------------------------------------------------------------------- 
' Module    : Module1 
' Procedure : Main 
' Author    : Case (Ralf Stolzenburg) 
' Date      : 08.10.2012 
' Purpose   : Tabellenblaetter für jeden Tag des Jahres erstellen 
'-------------------------------------------------------------------------- 
Public Sub Main()
    Dim intDays As Integer
    Dim datDate As Date
    Dim lngCal As Long
    On Error GoTo Fin
    With Application
        .ScreenUpdating = False
        .AskToUpdateLinks = False
        .EnableEvents = False
        lngCal = .Calculation
        .Calculation = xlCalculationManual
        .DisplayAlerts = False
    End With
    With ThisWorkbook
        For intDays = 2 To IIf(Day(DateSerial(Year(.Worksheets _
            (.Worksheets.Count).Range("A1").Value), 2 + 1, 0)) = 29, 366, 365)
            datDate = .Worksheets(.Worksheets.Count).Range("A1").Value
            .Worksheets(1).Copy After:=.Worksheets(.Worksheets.Count)
            .Worksheets(.Worksheets.Count).Name = _
                DateSerial(Year(datDate), Month(datDate), Day(datDate) + 1)
            .Worksheets(.Worksheets.Count).Range("A1").Value = _
                .Worksheets(.Worksheets.Count).Name
        Next intDays
    End With
Fin:
    With Application
        .Goto (ThisWorkbook.Worksheets(1).Range("A1")), True
        .ScreenUpdating = True
        .AskToUpdateLinks = True
        .EnableEvents = True
        .Calculation = lngCal
        .DisplayAlerts = True
    End With
    If Err.Number <> 0 Then MsgBox "Error: " & _
        Err.Number & " " & Err.Description
End Sub

06.10.2012

UserForm - Suchen - Ändern - Schreiben...

Frage: In Sheet2 habe ich in Spalte A Indexnummern und in den Spalten B-D dazugehörige Informationen. Über eine UserForm würde ich nun gerne in einem Textfeld eine Indexnummer eingeben und in den anderen drei Textfeldern sollen dann die entsprechenden Werte dazu angezeigt werden.

In TextBox1 soll man nur Zahlen eingeben können.

Ist die Indexnummer nicht vorhanden, soll eine Neueingabe möglich sein. TextBox1 und TextBox2 müssen ausgefüllt sein - sonst Meldung. Dann Eingabe der Werte in die erste freie Zeile in Sheet2. Wie geht das?

Hier noch eine Beispieldatei: UserForm - Suchen - Eingabe - Ändern...

Code gehört in den Codebereich der UserForm (4 TextBoxen und 1 CommandButton):

Option Explicit
'--------------------------------------------------------------------------
' Module    : UserForm1
' Procedure : TextBox1_Change
' Author    : Case (Ralf Stolzenburg)
' Date      : 06.10.2012
' Purpose   : UserForm TextBox Search Change...
'--------------------------------------------------------------------------
Private Sub TextBox1_Change()
    Dim varTMP As Variant
    On Error GoTo Fin
    If Not Trim(TextBox1.Text) = "" Then
        With Sheet2
            varTMP = Application.Match(CLng(TextBox1.Text), .Range("A:A"), 0)
            If Not IsError(varTMP) Then
                Me.Tag = varTMP
                TextBox2.Text = .Cells(varTMP, 2).Value
                TextBox3.Text = .Cells(varTMP, 3).Value
                TextBox4.Text = .Cells(varTMP, 4).Value
            Else
                Me.Tag = ""
                TextBox2.Text = ""
                TextBox3.Text = ""
                TextBox4.Text = ""
            End If
        End With
    Else
        TextBox2.Text = ""
        TextBox3.Text = ""
        TextBox4.Text = ""
    End If
Fin:
    If Err.Number <> 0 Then MsgBox "Error: " & _
        Err.Number & " " & Err.Description
End Sub
Private Sub TextBox1_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
    If Chr(KeyAscii) Like "[0-9]" = False Then KeyAscii = 0
End Sub
Private Sub CommandButton1_Click()
    Dim lngRow As Long
    On Error GoTo Fin
    If Trim(TextBox1.Text) <> "" And Trim(TextBox2.Text) <> "" Then
        If Me.Tag <> "" Then
            With Sheet2
                .Cells(Me.Tag, 1).Value = CLng(TextBox1.Text)
                .Cells(Me.Tag, 2).Value = TextBox2.Text
                .Cells(Me.Tag, 3).Value = TextBox3.Text
                .Cells(Me.Tag, 4).Value = TextBox4.Text
            End With
        Else
            With Sheet2
                lngRow = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
                .Cells(lngRow, 1) = CLng(TextBox1.Text)
                .Cells(lngRow, 2) = TextBox2.Text
                .Cells(lngRow, 3) = TextBox3.Text
                .Cells(lngRow, 4) = TextBox4.Text
            End With
        End If
            TextBox1.Text = ""
    Else
        MsgBox ("Entry incomplete!")
        TextBox1.SetFocus
    End If
Fin:
    If Err.Number <> 0 Then MsgBox "Error: " & _
        Err.Number & " " & Err.Description
End Sub

Code in ein allgemeines Modul:

Option Explicit
Sub UF_Show()
    UserForm1.Show 0
End Sub

Formeln auf einer UserForm in einer TextBox darstellen...

Formeln auf einer UserForm in einer TextBox anzeigen. Z. B. "Formula", "FormulaLocal"... und wie muss die Formel in VBA ...