20.07.2012

Verknüpfung auf einen Ordner in anderem Ordner erstellen

Frage: Auf einen Ordner soll eine Verknüpfung erstellt werden - Diese aber in einem anderen Ordner abgelegt werden. Geht das?

Option Explicit
Sub Main()
    Dim strTarget As String
    Dim objShell As Object
    Dim strPath As String
    Dim strName As String
    Dim objLink As Object
    Dim objFSO As Object
    On Error GoTo Fin
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    Set objShell = CreateObject("WScript.Shell")
    strPath = "C:\Temp\" ' Dieser Ordner wird verknüpft
    strName = "Temp" ' Das ist der Name der Verknüpfung
    strTarget = "E:\Excel\" ' Das ist das Ziel der Verknüpfung
    Set objLink = objShell.CreateShortcut _
        (strTarget & strName & ".lnk")
    objLink.TargetPath = strPath
    objLink.WorkingDirectory = strPath
    objLink.Save
Fin:
    Set objLink = Nothing
    Set objShell = Nothing
    Set objFSO = Nothing
    If Err.Number <> 0 Then MsgBox "Error: " & _
        Err.Number & " " & Err.Description
End Sub

Worddatei - Tabelle - Zeilen hinzufügen

Frage: In einer Worddatei ist eine Tabelle. In dieser Tabelle möchte ich am Ende bzw. zwischendrin Zeilen einfügen - das Ganze aus Excel. Wie geht das?

Option Explicit
Public Sub Main()
    Dim objTable As Object
    Dim objWDApp As Object
    Dim objWDDoc As Object
    Dim objRow As Object
    On Error GoTo Fin
    Set objWDApp = OffApp("Word")
    If Not objWDApp Is Nothing Then
        Set objWDDoc = objWDApp.Documents.Open _
            (ThisWorkbook.Path & Application.PathSeparator & "Doc1.doc")
        Set objTable = objWDDoc.Tables(1)
        With objTable
            Debug.Print .Rows.Count
            .Rows.Add ' Am Ende Zeile einfuegen
            Set objRow = .Rows.Add(BeforeRow:=.Rows(3))
            Debug.Print .Rows.Count
        End With
    End If
Fin:
    Set objRow = Nothing
    Set objTable = Nothing
    Set objWDDoc = Nothing
    Set objWDApp = Nothing
    If Err.Number <> 0 Then MsgBox "Fehler: " & _
        Err.Number & " " & Err.Description
End Sub
Private Function OffApp(ByVal strApp As String) 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")
            objApp.Visible = True
            If Err.Number > 0 Then
                MsgBox Err.Number & " " & Err.Description
                Set objApp = Nothing
            End If
        Case 0
        Case Else
            MsgBox Err.Number & " " & Err.Description
            Set objApp = Nothing
    End Select
    On Error GoTo 0
    Set OffApp = objApp
    Set objApp = Nothing
End Function

Hier noch ein Beispiel mit Worddatei: Sample

Ordner erstellen Liste in Spalte A und B - Link in Spalte C

Frage: In Spalte A und B habe ich eine fortlaufende Liste. Aus diese beiden Werten - also z. B. A1 und B1 - sollen Ordner erstellt werden. In Spalte C soll ein Link zu dem neu erstellten Ordner gelegt werden. Wie geht das?

Option Explicit
Declare Function MakeSureDirectoryPathExists _
    Lib "imagehlp.dll" (ByVal Pfad As String) As Long
Const strPath As String = "C:\Temp\" ' adapt
Public Sub Main()
    Dim lngCount As Long
    With ThisWorkbook.Worksheets("Sheet1") ' adapt
        For lngCount = 2 To .Range("A" & .Rows.Count).End(xlUp).Row
            MakeSureDirectoryPathExists strPath & .Cells(lngCount, 1).Text & _
                "_" & .Cells(lngCount, 2).Text & "\"
            .Hyperlinks.Add _
                Anchor:=.Cells(lngCount, 3), _
                Address:=strPath & .Cells(lngCount, 1).Text & "_" & _
                    .Cells(lngCount, 2).Text & "\", _
                    TextToDisplay:=.Cells(lngCount, 1).Text
        Next lngCount
    End With
End Sub

Hier noch eine Beispieldatei: Sample

Tabellenblatt aus allen Dateien kopieren

Frage: Aus allen Dateien eines Ordners soll das erste Tabellenblatt jeweils als neues Blatt in eine Zusammenfassung kopiert werden, wie geht das?

Option Explicit
Public Sub Main()
    Dim strFileName As String
    Dim strPath As String
    On Error GoTo Fin
    strPath = "C:\Temp\Test\" ' anpassen!!!
    Application.ScreenUpdating = False
    strFileName = Dir$(strPath & "*.xls*")
    If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
    Do While strFileName <> ""
        If Not strFileName = ThisWorkbook.Name Then
            Workbooks.Open strPath & strFileName, ReadOnly:=True
            With ActiveWorkbook
                .Worksheets(1).Copy _
                    After:=ThisWorkbook.Worksheets _
                    (ThisWorkbook.Worksheets.Count)
                .Close False
            End With
        End If
        strFileName = Dir$()
    Loop
Fin:
    Application.ScreenUpdating = True
    If Err.Number <> 0 Then MsgBox "Fehler: " & _
        Err.Number & " " & Err.Description
End Sub

Sollen auch Dateien aus Unterordner berücksichtigt werden, folgenden Code nehmen:
Mit Unterordner

19.07.2012

Alle Dateien eines Ordners - Optional mit Unterordner

Frage: Kann mir mal jemand ein Grundgerüst an die Hand geben, mit dem alle Dateien eines Ordners (optional mit Unterordner) berücksichtigt werden.

Option Explicit
' Suchmuster gegebenenfalls anpassen 
Const strEX As String = "*.xls*"
'-------------------------------------------------------------------------- 
' Module    : Module1 
' Procedure : Files_Read 
' Author    : Case (Ralf Stolzenburg) 
' Date      : 15.10.2012 
' Purpose   : Alle Dateien eines Ordners - Optional mit Unterordner... 
'-------------------------------------------------------------------------- 
Public Sub Files_Read()
    Dim stCalc As Integer
    Dim strDir As String
    Dim objFSO As Object
    Dim objDir As Object
    On Error GoTo Fin
    With Application
        .ScreenUpdating = False
        .AskToUpdateLinks = False
        .EnableEvents = False
        stCalc = .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)
    'dirInfo objDir, strEX, True ' Mit Unterordner 
    dirInfo objDir, strEX ' Ohne Unterordner 
Fin:
    With Application
        ' Bei Bedarf 
        '.Goto (ThisWorkbook.Worksheets(1).Range("A1")), True 
        .ScreenUpdating = True
        .AskToUpdateLinks = True
        .EnableEvents = True
        .Calculation = stCalc
        .DisplayAlerts = True
    End With
    Set objDir = Nothing
    Set objFSO = Nothing
End Sub
'-------------------------------------------------------------------------- 
' Module    : Module1 
' Procedure : dirInfo 
' Author    : Case (Ralf Stolzenburg) 
' Date      : 15.10.2012 
' Purpose   : Rekursive Funktion alle Dateien... 
'-------------------------------------------------------------------------- 
Public Sub dirInfo(ByVal objCurrentDir As Object, ByVal strName As String, _
    Optional ByVal blnTMP As Boolean = False)
    Dim varTMP As Variant
    For Each varTMP In objCurrentDir.Files
        If varTMP.Name Like strName Then
            If varTMP.Name <> ThisWorkbook.Name Then
                If Left(varTMP.Name, 1) <> "~" Then
                    ' Hier jetzt der Code um mit der Datei etwas zu machen 
                    ' z. B. Öffnen, etwas auslesen oder was auch immer... 
                    ' Im folgenden werden nur ein paar Informationen 
                    ' im Direktfenster (VBE - STRG+G) ausgegeben 
                    ' Diese Zeilen mit Debug.Print können natürlich 
                    ' gelöscht bzw. auskommentiert werden 
                    Debug.Print "Pfad: " & varTMP.ParentFolder.Path
                    Debug.Print "Pfad & Datei: " & varTMP.Path
                    Debug.Print "Name: " & varTMP.Name
                    Debug.Print "Erstelldatum: " & varTMP.DateCreated
                    Debug.Print "Letzter Zugriff: " & varTMP.DateLastAccessed
                    Debug.Print "Letzte Änderung: " & varTMP.DateLastModified
                    Debug.Print "Größe in Byte: " & varTMP.Size
                    Debug.Print "Type: " & varTMP.Type
                    Debug.Print "Anzahl ALLE: " & varTMP.ParentFolder.Files.Count
                    Debug.Print vbCrLf
                End If
            End If
        End If
    Next varTMP
    If blnTMP = True Then
        For Each varTMP In objCurrentDir.SubFolders
            dirInfo varTMP, strName, blnTMP
        Next varTMP
    End If
End Sub

18.07.2012

Hyperlinks entfernen

Frage: Ich füge in eine Liste per Drag & Drop E-Mail-Adressen von einer Webseite ein. Excel macht daraus Hyperlinks, obwohl ich die Option "Internet- und Netzwerkpfade durch Hyperlinks während der Bearbeitung übernehmen" abgewählt habe. Was kann ich machen?

Vor dem Einfügen (rechte Maustaste auf den Tabellenreiter und dann "Code anzeigen" anklicken):

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
    Me.Cells.Hyperlinks.Delete
End Sub

Nach dem Einfügen für das gerade aktive Tabellenblatt (in ein Modul):

Option Explicit
Sub Main()
    Cells.Hyperlinks.Delete
End Sub

Bilder untereinander einfügen

Frage: In einem Ordner (optional mit Unterordner) sind viele Bilddateien (jpg). Diese sollen ab A1 untereinander eingefügt werden. Die Zeilenhöhe ist schon angepasst. Wie geht das?

Option Explicit
Dim objPicture As Picture
Dim objFSO As Object
Public Sub Main()
    Dim shpShape As Shape
    Dim strPath As String
    On Error GoTo Fin
    strPath = "C:\Temp\Test\"
    If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
    Application.ScreenUpdating = False
    With ThisWorkbook.Worksheets(1)
        For Each shpShape In .Shapes
            If shpShape.TopLeftCell.Column = 1 Then shpShape.Delete
        Next shpShape
    End With
    SearchFiles strPath, "*.jpg", False ' ohne Unterordner
    'SearchFiles strPath, "*.jpg", True ' mit Unterordner
Fin:
    Set objPicture = Nothing
    Set objFSO = Nothing
    Application.ScreenUpdating = True
    If Err.Number <> 0 Then MsgBox "Error: " & _
        Err.Number & " " & Err.Description
End Sub
Private Sub SearchFiles(strFolder As String, strFileName As String, _
    Optional blnTMP As Boolean = False)
    Dim objFolder As Object
    Dim objFile As Object
    Dim lngRow As Long
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    For Each objFile In objFSO.GetFolder(strFolder).Files
        If objFile.Name Like strFileName Then
            With ThisWorkbook.Worksheets(1)
                With .Cells(lngRow + 1, 1)
                    Set objPicture = .Parent.Pictures.Insert(objFile.Path)
                    objPicture.Top = .Top
                    objPicture.Left = .Left
                    objPicture.Height = .Height
                    objPicture.Width = .Width
                End With
                lngRow = lngRow + 1
            End With
        End If
    Next objFile
    If blnTMP = True Then
        For Each objFolder In objFSO.GetFolder(strFolder).Subfolders
            SearchFiles strFolder & "\" & objFolder.Name, strFileName, blnTMP
        Next objFolder
    End If
End Sub

Sind schon Bilder eingfügt und Du möchtest die Zeilenhöhe an die Bilder anpassen, dann so (beachte den Hinweis von Nepumuk im Link unten):

Option Explicit
Sub Main()
    Dim shpShape
    On Error GoTo Fin
    Application.ScreenUpdating = False
    For Each shpShape In Tabelle1.Shapes
        'If shpShape.Type = msoPicture Then
        ' in Excel 2010
        If shpShape.Type = msoLinkedPicture Then
            Rows(shpShape.TopLeftCell.Row).RowHeight = shpShape.Height
        End If
    Next shpShape
Fin:
    Application.ScreenUpdating = True
    If Err.Number <> 0 Then MsgBox "Error: " & _
        Err.Number & " " & Err.Description
End Sub

Hinweis Nepumuk...

PowerPoint aus Excel - Format 16:9

Frage: Besteht die Möglichkeit das Seitenformat einer neu zu erstellenden PowerPoint Präsentation per VBA aus Excel heraus auf 16:9 umzustellen?

Option Explicit
Const ppSlideSizeOnScreen16x9 As Long = 15
Const ppLayoutBlank As Long = 12
Dim blnPPT As Boolean
Dim objPP As Object
Public Sub Main()
    On Error GoTo Fin
    Set objPP = OffApp("PowerPoint")
    If Not objPP Is Nothing Then
        With objPP
            .Visible = True
            .Presentations.Add
            .ActivePresentation.Slides.Add 1, ppLayoutBlank
            .ActivePresentation.PageSetup.SlideSize = ppSlideSizeOnScreen16x9
        End With
    Else
        MsgBox "Application not installed!"
    End If
Fin:
    MsgBox "Nach Klick wird PowerPoint wieder geschlossen!", 64
    If Not objPP Is Nothing Then
        If blnPPT = True Then
            objPP.Quit
            blnPPT = False
        End If
    End If
    Set objPP = Nothing
    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
    On Error Resume Next
    Set objPP = GetObject(, strApp & ".Application")
    Select Case Err.Number
        Case 429
            Err.Clear
            Set objPP = CreateObject(strApp & ".Application")
            blnPPT = True
            If blnVisible = True Then
                On Error Resume Next
                objPP.Visible = True
                Err.Clear
            End If
    End Select
    On Error GoTo 0
    Set OffApp = objPP
    Set objPP = Nothing
End Function

Datei speichern Dialog - Format

Frage: Ein Datei-Speichern-Unter-Dialog soll angezeigt werden. Mit den Möglichkeiten als "XLSM = 52" oder "XLSX = 51" zu speichern. Die verschiedenen Formate sind unten nochmal aus der VBA-Hilfe kopiert. Wenn als "XLSX = 51" gespeichert wird, werden die Makros automatisch aus der Datei entfernt. Im zweiten Code sieht man, wie das Standardspeicherformat ausgegeben bzw. angepasst werden kann.

Option Explicit
Public Sub Main()
    Dim varFilename As Variant
    ActiveSheet.Copy
    varFilename = Application.GetSaveAsFilename( _
    fileFilter:=("Exceldateien mit Makro(*.xlsm)," & _
    "*.xlsm,Exceldateien ohne Makro (*.xlsx),*.xlsx"), _
    InitialFileName:="Testdatei" & ".xlsm")
    If varFilename <> False Then ActiveWorkbook.SaveAs varFilename, _
        IIf(Right(varFilename, 4) = "xlsm", 52, 51)
    'ActiveWorkbook.Close False
End Sub
Sub Main_1()
    Dim lngTMP As Long
    lngTMP = Application.DefaultSaveFormat
    MsgBox Application.DefaultSaveFormat
    Application.DefaultSaveFormat = xlOpenXMLWorkbookMacroEnabled
    MsgBox Application.DefaultSaveFormat
    Application.DefaultSaveFormat = lngTMP
    MsgBox Application.DefaultSaveFormat
End Sub

Gibt beim Speichern des Arbeitsblatts das Dateiformat an.
Hinzugefügte Version: Excel 2007
NameWertBeschreibung
xlAddIn18Microsoft Excel 97-2003 Add-In
xlAddIn818Microsoft Excel 97-2003 Add-In
xlCSV6CSV
xlCSVMac22CSV (Macintosh)
xlCSVMSDOS24CSV (MSDOS)
xlCSVWindows23CSV (Windows)
xlCurrentPlatformText-4158Aktueller Plattformtext
xlDBF27DBF2
xlDBF38DBF3
xlDBF411DBF4
xlDIF9DIF
xlExcel1250Excel12
xlExcel216Excel2
xlExcel2FarEast27Excel2 FarEast
xlExcel329Excel3
xlExcel433Excel4
xlExcel4Workbook35Excel4-Arbeitsmappe
xlExcel539Excel5
xlExcel739Excel7
xlExcel856Excel8
xlExcel979543Excel9795
xlHtml44HTML-Format
xlIntlAddIn26Internationales Add-In
xlIntlMacro25Internationales Makro
xlOpenDocumentSpreadsheet60OpenDocument-Kalkulationstabelle
xlOpenXMLAddIn55Open XML-Add-In
xlOpenXMLTemplate54Open XML-Vorlage
xlOpenXMLTemplateMacroEnabled53Open XML-Vorlage mit Makros
xlOpenXMLWorkbook51Open XML-Arbeitsmappe
xlOpenXMLWorkbookMacroEnabled52Open XML-Arbeitsmappe mit Makros
xlSYLK2SYLK
xlTemplate17Vorlage
xlTemplate817Vorlage 8
xlTextMac19Macintosh-Text
xlTextMSDOS21MSDOS-Text
xlTextPrinter36Druckertext
xlTextWindows20Windows Text
xlUnicodeText42Unicode Text
xlWebArchive45Webarchiv
xlWJ2WD114WJ2WD1
xlWJ340WJ3
xlWJ3FJ341WJ3FJ3
xlWK15WK1
xlWK1ALL31WK1ALL
xlWK1FMT30WK1FMT
xlWK315WK3
xlWK3FM332WK3FM3
xlWK438WK4
xlWKS4Arbeitsblatt
xlWorkbookDefault51Arbeitsblatt Standard
xlWorkbookNormal-4143Arbeitsblatt normal
xlWorks2FarEast28Works2 FarEast
xlWQ134WQ1
xlXMLSpreadsheet46XML-Kalkulationstabelle
Diese Tabelle wurde mit Tab2Html (v2.4.1) erstellt. ©Gerd alias Bamberg

Geschlossene Dateien - Range auslesen

Frage: Aus geschlossenen Exceldateien (alle eines Ordners - optional mit Unterordner) soll über VBA per Formel der Range A2:Y15 ausgelesen werden und ab Zeile 2 in einer Hauptdatei eingefügt werden. Bei erneutem ausführen des Codes sollen die alten Daten erst gelöscht werden. Ab Zeile 2, da die erste Zeile eine Überschrift enthält.

Option Explicit
Const strSheetQ As String = "Tabelle1" ' DIE Tabelle wird ausgelesen"
Const strSheetZ As String = "Gesamt" ' Die Tabelle in DIESER Datei
Const strRange As String = "A2:Y15" ' Der Bereich wird ausgelesen
Public Sub Files_Read()
    Dim stCalc As Integer
    Dim strDir As String
    Dim objFSO As Object
    Dim objDir As Object
    On Error GoTo Fin
    With Application
        .ScreenUpdating = False
        .AskToUpdateLinks = False
        .EnableEvents = False
        stCalc = .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)
        .Rows("2:" & .Rows.Count).ClearContents
        'dirInfo objDir, "*.xls*", True ' Mit Unterordner
        dirInfo objDir, "*.xls*" ' Ohne Unterordner
        .UsedRange.Value = .UsedRange.Value
    End With
Fin:
    With Application
        .Goto (ThisWorkbook.Worksheets(strSheetZ).Range("A1")), True
        .ScreenUpdating = True
        .AskToUpdateLinks = True
        .EnableEvents = True
        .Calculation = stCalc
        .DisplayAlerts = True
    End With
    Set objDir = Nothing
    Set objFSO = Nothing
End Sub
Public Sub dirInfo(ByVal objCurrentDir As Object, ByVal strName As String, _
    Optional ByVal blnTMP As Boolean = False)
    Dim objWorkbook As Workbook
    Dim strFormula As String
    Dim lngLastRow As Long
    Dim varTMP As Variant
    Dim strTMP As String
    strTMP = Range(strRange).Address(RowAbsolute:=True, _
        ColumnAbsolute:=True, ReferenceStyle:=xlR1C1)
    For Each varTMP In objCurrentDir.Files
        If varTMP.Name Like strName And varTMP.Name <> _
            ThisWorkbook.Name And Left(varTMP.Name, 1) <> "~" Then
            With ThisWorkbook.Worksheets(strSheetZ)
                lngLastRow = IIf(Len(.Cells(.Rows.Count, 1)), _
                    .Rows.Count, .Cells(.Rows.Count, 1).End(xlUp).Row) + 1
                With .Range(.Cells(lngLastRow, 1), _
                    .Cells(Range(strRange).Rows.Count + lngLastRow - 1, _
                    Range(strRange).Columns.Count))
                    .FormulaArray = "='" & Mid(varTMP.Path, 1, _
                        InStrRev(varTMP.Path, "\")) & "[" & _
                        Mid(varTMP.Path, InStrRev(varTMP.Path, _
                        "\") + 1) & "]" & _
                        strSheetQ & "'!" & strRange
                End With
            End With
        End If
    Next varTMP
    If blnTMP = True Then
        For Each varTMP In objCurrentDir.SubFolders
            dirInfo varTMP, strName, blnTMP
        Next varTMP
    End If
    Set objWorkbook = Nothing
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 ...