Microsoft Excel

Herbers Excel/VBA-Archiv

Informationen und Beispiele zum Thema MsgBox
BildScreenshot zu MsgBox MsgBox-Seite mit Beispielarbeitsmappe aufrufen

„Automatisches“ Makro per Makro ändern

Betrifft: „Automatisches“ Makro per Makro ändern von: norbert62
Geschrieben am: 05.09.2004 23:03:03

Folgende Konstante hätte ich gerne per Makro geändert

Sie steht in DieseArbeitsmappe Allgemein

Const TBL_TARGET = "Tabelle1"

Ich würde daraus gerne folgende Konstante machen

Const TBL_TARGET = "Tabelle2"


Hintergrund ist der, dass in 31 Arbeitsmappen (Tagesproduktionszahlen) dieses Makro liegt. Zieltabelle ist dann eben immer die entsprechende, also Tabelle1 bis Tabelle31. Das Makro läuft dann beim Schließen automatisch (bevore Close)

Manchmal muss ich größere Änderungen in den Arbeitsmappen vornehmen. Das mache ich dann nur in der ersten und speichere dann die restlichen 30 nur neu ab. Dann habe ich aber immer die Tabelle1 als Ziel und muss dies nun von Hand ändern.

  


Betrifft: AW: „Automatisches“ Makro per Makro ändern von: Nepumuk
Geschrieben am: 06.09.2004 05:34:56

Hallo Norbert,
versuch es damit:


Option Explicit

Private Declare Function FindFirstFile Lib "kernel32" Alias "FindFirstFileA" (ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindNextFile Lib "kernel32" Alias "FindNextFileA" (ByVal hFindFile As Long, lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindClose Lib "kernel32" (ByVal hFindFile As LongAs Long

Private Const MAX_PATH = 260
Private Const INVALID_HANDLE_VALUE = -1
Private Const FILE_ATTRIBUTE_ARCHIVE = &H20
Private Const FILE_ATTRIBUTE_DIRECTORY = &H10
Private Const FILE_ATTRIBUTE_HIDDEN = &H2
Private Const FILE_ATTRIBUTE_NORMAL = &H80
Private Const FILE_ATTRIBUTE_READONLY = &H1
Private Const FILE_ATTRIBUTE_SYSTEM = &H4
Private Const FILE_ATTRIBUTE_TEMPORARY = &H100

Private Type FILETIME
    dwLowDateTime As Long
    dwHighDateTime As Long
End Type

Private Type WIN32_FIND_DATA
    dwFileAttributes As Long
    ftCreationTime As FILETIME
    ftLastAccessTime As FILETIME
    ftLastWriteTime As FILETIME
    nFileSizeHigh As Long
    nFileSizeLow As Long
    dwReserved0 As Long
    dwReserved1 As Long
    cFileName As String * MAX_PATH
    cAlternate As String * 14
End Type

Private lngDirCount As Long
Private lngFileCount As Long
Private strFiles() As String

Public Sub start()
    Dim lngIndex As Long, strDateiname As String, myFSO As Object, myDrive As Object
    lngDirCount = 1
    lngFileCount = 0
    
'   ******************* Diesen Teil verwenden, wenn alle Mappen auf allen Laufwerke bearbeitet werden

'    Set myFSO = CreateObject("Scripting.FileSystemObject")
'    For Each myDrive In myFSO.Drives
'        If myDrive.IsReady Then Call FindFiles(myDrive.DriveLetter & ":\", "*.xls")
'    Next
'    Set myFSO = Nothing

'   **************************************************************************************************


'   ******************* Diesen Teil verwenden, wenn alle Mappen in einem Ordner bearbeitet werden

    Call FindFiles("D:\Eigene Dateien\Eigene Tabellen\", "*.xls")
    
'   **************************************************************************************************

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With
    For lngIndex = 1 To lngFileCount
        If strFiles(lngIndex) <> ThisWorkbook.FullName Then
            strDateiname = Right(strFiles(lngIndex), InStr(1, StrReverse(strFiles(lngIndex)), "\") - 1)
            Workbooks.Open strFiles(lngIndex)
            Call Teistring_tauschen(strDateiname)
            Workbooks(strDateiname).Close SaveChanges:=True
        End If
    Next
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
    MsgBox "Fertig.", 64, "Info"
End Sub

Private Sub FindFiles(ByVal strFolderPath As StringByVal strSearch As String)
    Dim WFD As WIN32_FIND_DATA, lngSearch As Long, strDirName As String
    If Right$(strFolderPath, 1) <> "\" Then strFolderPath = strFolderPath & "\"
    lngSearch = FindFirstFile(strFolderPath & "*.*", WFD)
    If lngSearch <> INVALID_HANDLE_VALUE Then
        GetFilesInFolder strFolderPath, strSearch
        Do
            If (WFD.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) Then
                strDirName = TrimNulls(WFD.cFileName)
                If (strDirName <> ".") And (strDirName <> "..") Then
                    lngDirCount = lngDirCount + 1
                    FindFiles strFolderPath & strDirName, strSearch
                End If
            End If
        Loop While FindNextFile(lngSearch, WFD)
        FindClose lngSearch
    End If
End Sub

Private Sub GetFilesInFolder(ByVal strFolderPath As StringByVal strSearch As String)
    Dim WFD As WIN32_FIND_DATA, lngSearch As Long, strFileName As String
    If Right$(strFolderPath, 1) <> "\" Then strFolderPath = strFolderPath & "\"
    lngSearch = FindFirstFile(strFolderPath & strSearch, WFD)
    If lngSearch <> INVALID_HANDLE_VALUE Then
        Do
            If (WFD.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) <> FILE_ATTRIBUTE_DIRECTORY Then
                strFileName = TrimNulls(WFD.cFileName)
                lngFileCount = lngFileCount + 1
                ReDim Preserve strFiles(1 To lngFileCount)
                strFiles(lngFileCount) = strFolderPath & strFileName
            End If
        Loop While FindNextFile(lngSearch, WFD)
        FindClose lngSearch
    End If
End Sub

Private Function TrimNulls(ByVal strStringIn As StringAs String
    If InStr(strStringIn, Chr(0)) > 0 Then strStringIn = Left$(strStringIn, InStr(strStringIn, Chr(0)) - 1)
    TrimNulls = strStringIn
End Function

Private Sub Teistring_tauschen(strDateiname As String)
    Dim objVBC As Object, lngLine As Long
    For Each objVBC In Workbooks(strDateiname).VBProject.VBComponents
        With objVBC.CodeModule
            For lngLine = 1 To .CountOfLines
                If Trim$(.Lines(lngLine, 1)) = "Const TBL_TARGET = " & Chr(34) & "Tabelle1" & Chr(34) Then
                    .DeleteLines lngLine
                    .InsertLines lngLine, "Const TBL_TARGET = " & Chr(34) & "Tabelle2" & Chr(34)
                    Exit Sub
                End If
            Next
        End With
    Next
End Sub


Gruß
Nepumuk


  


Betrifft: AW: Danke von: norbert62
Geschrieben am: 06.09.2004 08:49:18

hallo Nepumuk,

wenn man bisher nur mit dem Recorder gearbeitet hat erschrekt einem dieses Makro im ersten Moment.

Ich habe ein paar Tage frei und werde dann, wenn ich in die Arbeit komme versuchen das Makro einzubauen.


Danke
Norbert