Excel Makro - HILFE!

Dieses Thema Excel Makro - HILFE! im Forum "Microsoft Office Suite" wurde erstellt von Unwissender, 3. Feb. 2005.

Thema: Excel Makro - HILFE! hallo zusammen ... da ich mich absolut nicht auskenne im makros programmieren, aber ganz ganz dringend so ein teil...

  1. hallo zusammen ...
    da ich mich absolut nicht auskenne im makros programmieren, aber ganz ganz dringend so ein teil brauche für meine auswertungen, wende ich mich mal ganz unverschämt an euch.

    folgendes problem:
    ich habe 3500 ASCII-dateien (sollte man aber variabel einstellen können wieviele) in denen 4-stelligen zahlen stehen, und zwar in 96 spalten und 96 zeilen (das sollte auch variabel sein), davon muss ich 9 felder zu einem mittelwert zusammenfassen und diese dann in ein neues sheet schreiben (9 werte pro zeile).

    das mit dem mittelwert krieg ich schon irgendwie hin, wie aber kann ich ihm sagen: öffne 300 dateien und lass über diese mein makro laufen, kopier nach jedem makro-durchlauf die mittelwerte in ein neues sheet.


    kann mir da jemand weiterhelfen????
    bitte bitte ... :-\
     
  2. Hi Unwissender,

    liegen die Dateien alle in einem Verzeihnis ?

    Gruß Matjes :)
     
  3. Hi Unwissender,

    unter der Annahme das alle files in einem Verzeichnis liegen hab ich dir einen Makro zusammengestellt:
    'a) mit Auswahl des Pfades
    'b) mit Abfrage des Filters für Dateinamen (z.B. D*.TXT)
    'c) die Dateinamen suchen und merken
    'd) Die gemerkten Dateien werden geöffnet
    'e) Ergebnis workbook neu anlegen
    'f) neues Ergebnisblatt anlegen
    'g) 9 Statistikwerte  + Mittelwert in Ergebnisblatt vermerken
    'h) 9 Statistikwerte  + Mittelwert in Übersichtsblatt vermerken
    'i) Mittelwert in Ergebnisblatt
    'j) gemerkte Dateien werden geschlossen

    Gruß Matjes  :)

    Code:
    Option Explicit
    
    ' Typdeklaration für API-Dialog->Verzeichnis auswählen'
       Private Type BrowseInfo
           hOwner          As Long
           pidlRoot        As Long
           pszDisplayName  As String
           lpszTitle       As String
           ulFlags         As Long
           lpfn            As Long
           lParam          As Long
           iImage          As Long
       End Type
    
       Private Declare Function SHGetPathFromIDList Lib shell32.dll (ByVal pidl As Long, ByVal pszPath As String) As Long
       Private Declare Function SHBrowseForFolder Lib shell32.dll (lpBrowseInfo As BrowseInfo) As Long
    
    ' Ermittelt Verzeichnisnamen und zeigt Windows-Dialog an
    Public Function VerzeichnisWählen(Optional DialogTitel) As String
       Dim StrukturVerzeichnisInfo As BrowseInfo, ListenNr As Long, Pfad As String
       Dim hWndAccessApp As Long
     
       With StrukturVerzeichnisInfo
           .hOwner = hWndAccessApp
           .lpszTitle = IIf(IsMissing(DialogTitel), Verzeichnispfad auswählen, CStr(DialogTitel))
           .ulFlags = &H1-> BIF_RETURNONLYFSDIRS
       End With
       
       ListenNr = SHBrowseForFolder(StrukturVerzeichnisInfo)
       Pfad = Space$(512)
       
       If SHGetPathFromIDList(ByVal ListenNr, ByVal Pfad) Then VerzeichnisWählen = Left(Pfad, InStr(Pfad, vbNullChar) - 1)
       
    End Function
    
    
    
    Public Sub FilesAusVerzeichnis_AuswertungMittelwert()
    'a) mit Auswahl des Pfades
    'b) mit Abfrage des Filters für Dateinamen (z.B. D*.TXT)
    'c) die Dateinamen suchen und merken
    'd) Die gemerkten Dateien werden geöffnet
    'e) Ergebnis workbook neu anlegen
    'f) neues Ergebnisblatt anlegen
    'g) 9 Statistikwerte  + Mittelwert in Ergebnisblatt vermerken
    'h) 9 Statistikwerte  + Mittelwert in Übersichtsblatt vermerken
    'i) Mittelwert in Ergebnisblatt
    'j) gemerkte Dateien werden geschlossen
    
    
    Dim fs As FileSearch
    Dim i As Long, z As Long, ret As Integer
    Dim sPath As String, sname As String, s_tmp As String
    Dim sSuchpfad As String, sFilename As String
    Dim f() As String, f_cnt As Long
    Dim dummy_StatistikErgebnisMittelwert As Double
    
    -> Auswahl des Pfades
     sSuchpfad = VerzeichnisWählen(Bitte wählen Sie das Verzeichnis)
    
     If sSuchpfad =  Then
       ret = MsgBox(Es wurde kein Suchpfad eingegeben ! & vbCrLf & Der Makro wird beendet., _
               vbOKOnly + vbInformation, Kein Suchpfad ausgewählt)
     Else
       
       'Wahl: Filename
       sFilename = InputBox(Geben Sie bitte den Filter für Filenamen ein !, Eingabe Filter Filname, *.*)
       If sFilename =  Then sFilename = *.*
    
       sPath = ActiveWorkbook.Path->Pfad des Dokuments
       sname = ActiveWorkbook.Name->Name des Dokuments
         
       'Feld initialisieren
       f_cnt = 0: ReDim f(1 To 1)
       
       'Filenamen aus dem Directory sPath auflisten
        Set fs = Application.FileSearch
        With fs
           .NewSearch
           .LookIn = sSuchpfad
           .FileName = sFilename
           i = .Execute(SortBy:=msoSortByFileName, SortOrder:=msoSortOrderAscending)
           If .FoundFiles.Count > 0 Then
             For i = 1 To .FoundFiles.Count
               If .FoundFiles(i) <> (sPath & \ & sname) Then->nicht dieses Dokument
                 s_tmp = .FoundFiles(i)
                 f_cnt = f_cnt + 1: ReDim Preserve f(1 To f_cnt)
                 f(f_cnt) = s_tmp
               End If
             Next i
           Else
             MsgBox Keine Dokumente gefunden
             Exit Sub
           End If
        End With
        
       ->wenn kein file vorhanden -> Ende
        If f_cnt > 0 Then
          Call ErgebnisseBilden(f(), f_cnt)
        End If
      End If
    End Sub
        
    Private Function NurFilenamen(s_vollstaendigerFilename As String) As String
    'schneidet die Pfadangaben aus einem String und gibt den Filenamen zurueck
    Dim p1 As Integer, p2 As Integer
    
     p2 = 0: p1 = 0
     Do
       p1 = InStr(p1 + 1, s_vollstaendigerFilename, \)
       If p1 <> 0 Then p2 = p1
     Loop While p1 <> 0
     NurFilenamen = Right(s_vollstaendigerFilename, Len(s_vollstaendigerFilename) - p2)
    End Function
    Sub ErgebnisseBilden(f() As String, f_cnt As Long)
        
      Dim wb_res As Workbook, ws_res As Worksheet, ws_erg As Worksheet
      Dim wb_akt As Workbook, ws_akt As Worksheet
      Dim z As Long, i As Long, x As Long
      Dim s_tmp As String
      
     ->Ergebnis-Workbook erzeugen
      Set wb_res = Workbooks.Add
     ->alle Blätter bis auf das erste löschen
      Application.DisplayAlerts = False
      Do While wb_res.Worksheets.Count > 1
        wb_res.Worksheets(wb_res.Worksheets.Count).Delete
      Loop
      Application.DisplayAlerts = False
      
     ->übriggebliebenes Blatt ist das Übersicht/Protokollblatt
      Set ws_res = Worksheets(Worksheets.Count)
      ws_res.Name = Übersicht
     ->Zeilenzähler für nächsten Eintrag initialisieren
      z = 1
     ->Überschriften
      ws_res.Cells(z, 1).Value = Statistikdaten 
      ws_res.Cells(z, 1).Font.Bold = True
      z = z + 1->Zeilenzaehler für naechsten Eintrag erhöhen
      ws_res.Cells(z, 1).Value = Filenamen: ws_res.Cells(z, 1).Font.Bold = True
      ws_res.Cells(z, 2).Value = Wert1: ws_res.Cells(z, 2).Font.Bold = True
      ws_res.Cells(z, 3).Value = Wert2: ws_res.Cells(z, 3).Font.Bold = True
      ws_res.Cells(z, 4).Value = Wert3: ws_res.Cells(z, 4).Font.Bold = True
      ws_res.Cells(z, 5).Value = Wert4: ws_res.Cells(z, 5).Font.Bold = True
      ws_res.Cells(z, 6).Value = Wert5: ws_res.Cells(z, 6).Font.Bold = True
      ws_res.Cells(z, 7).Value = Wert6: ws_res.Cells(z, 7).Font.Bold = True
      ws_res.Cells(z, 8).Value = Wert7: ws_res.Cells(z, 8).Font.Bold = True
      ws_res.Cells(z, 9).Value = Wert8: ws_res.Cells(z, 9).Font.Bold = True
      ws_res.Cells(z, 10).Value = Wert9: ws_res.Cells(z, 10).Font.Bold = True
      ws_res.Cells(z, 11).Value = Mittelwert: ws_res.Cells(z, 11).Font.Bold = True
      z = z + 1->Zeilenzaehler für naechsten Eintrag erhöhen
      
      For i = 1 To f_cnt
        Application.StatusBar = f_cnt & / & i
       ->Dateien nacheinander öffnen
        s_tmp = f(i)->nächster Dateiname
       ->Datei öffnen
        On Error GoTo Error_OpenFile
        Set wb_akt = Workbooks.Open(f(i))
       ->ggf hier das Trennzeichen mit angeben
       ->z.B. Trennzeichen Tabstop
       ->Set wb_akt = Workbooks.Open(f(i),,,1)
       ->Format Trennzeichen:1 Tabstops :2 Kommas:3 Leerzeichen:4 Semikolons
        On Error GoTo 0
       ->aktuelles Blatt ist Inhalt der Werte-Datei
        Set ws_akt = ActiveSheet
       ->Ergebnis vermerken
        ws_res.Cells(z, 1).Value = NurFilenamen(s_tmp)
       ->9 Werte auf Übersicht/Protokollblatt übertragen
       ->########## hier müssen noch die Zeilen/Spalten-Angaben
       ->########## auf ws_akt korrigiert werden (Zeile, Spalte)
        ws_res.Cells(z, 2).Value = ws_akt.Cells(1, 3).Value
        ws_res.Cells(z, 3).Value = ws_akt.Cells(1, 3).Value
        ws_res.Cells(z, 4).Value = ws_akt.Cells(1, 3).Value
        ws_res.Cells(z, 5).Value = ws_akt.Cells(1, 3).Value
        ws_res.Cells(z, 6).Value = ws_akt.Cells(1, 3).Value
        ws_res.Cells(z, 7).Value = ws_akt.Cells(1, 3).Value
        ws_res.Cells(z, 8).Value = ws_akt.Cells(1, 3).Value
        ws_res.Cells(z, 9).Value = ws_akt.Cells(1, 3).Value
        ws_res.Cells(z, 10).Value = ws_akt.Cells(1, 3).Value
       ->Mittelwert über die neun Werte
        ws_res.Cells(z, 11).Value = WorksheetFunction.Average( _
                ws_res.Range(ws_res.Cells(z, 2), ws_res.Cells(z, 10)))
        
       ->neues Blatt anlegen für Statistik-Daten
         Set ws_erg = wb_res.Worksheets.Add(After:=wb_res.Worksheets(wb_res.Worksheets.Count))
       ->9 Werte + Mittelwert auf neues Blatt übertragen
        ws_erg.Name = Erg & i
       ->Werte aus dem Übersichtsblatt in neues Blatt übertragen
        For x = 1 To 10
          ws_erg.Cells(1, x).Value = ws_res.Cells(z, x + 1).Value
        Next
    
       ->Werte-Datei schliessen
        wb_akt.Close SaveChanges:=False
        
       ->Zeilenzaehler für naechsten Eintrag erhöhen
       ->auf Übersichtsblatt
        z = z + 1
      Next i
      ws_res.Activate
    
    Aufraeumen:
     On Error Resume Next
     Set wb_res = Nothing: ws_res = Nothing: Set ws_erg = Nothing
     Set wb_akt = Nothing: ws_akt = Nothing
     On Error GoTo 0
     Application.StatusBar = 
     Exit Sub
    Error_OpenFile:
      Err.Clear
      MsgBox (Das file  & s_tmp &  konnte nicht geöffnet werden.)
      GoTo Aufraeumen
    End Sub
    
     
  4. vielen vielen dank für die hilfe!!!! ;)

    werde es gleich ausprobieren!!!

    DANKESCHÖN!!!! :D
     
  5. hallo, ich nochmal ... ::)

    lieber matjes, das programm funktioniert!!!! leider müsste man noch ein paar dinge ändern ... habe mich beim ersten mal nicht deutlich genug ausgedrückt.

    meine ascii-dateien bestehen aus 96 zeilen x 96 spalten. dieses datasheet möchte ich in 9 unterteilen und aus jedem 9tel den mittelwert bilden ... d.h. ich hab 9 felder der größe 32x32, aus diesen 1024 werten möchte ich den mittelwert, und das ganze 9mal (für die 9 untereinheiten).
    das makro soll mir also nur diese 9 mittelwerte ausgeben (am besten in einer zeile) und zwar (wenn möglich) nach folgender reihenfolge der 32x32-flächen:

    1 4 7
    2 5 8
    3 6 9


    ich weiss nicht, ob das einigermaßen klar geworden ist oder ob ich jetzt für noch mehr verwirrung gesorgt habe ...

    ist das möglich? :-\
     
  6. hallo ...

    hab's inzwischen so hingewurschtelt dass es klappt ...

    aber danke nochmal ...

    :D
     
  7. Ich hab das Makro nochmal deinen Wünschen entsprechend geändert.

    Gruß Matjes :)

    Code:
    ' Typdeklaration für API-Dialog->Verzeichnis auswählen'
       Private Type BrowseInfo
           hOwner          As Long
           pidlRoot        As Long
           pszDisplayName  As String
           lpszTitle       As String
           ulFlags         As Long
           lpfn            As Long
           lParam          As Long
           iImage          As Long
       End Type
    
       Private Declare Function SHGetPathFromIDList Lib shell32.dll (ByVal pidl As Long, ByVal pszPath As String) As Long
       Private Declare Function SHBrowseForFolder Lib shell32.dll (lpBrowseInfo As BrowseInfo) As Long
    
    ' Ermittelt Verzeichnisnamen und zeigt Windows-Dialog an
    Public Function VerzeichnisWählen(Optional DialogTitel) As String
       Dim StrukturVerzeichnisInfo As BrowseInfo, ListenNr As Long, Pfad As String
       Dim hWndAccessApp As Long
     
       With StrukturVerzeichnisInfo
           .hOwner = hWndAccessApp
           .lpszTitle = IIf(IsMissing(DialogTitel), Verzeichnispfad auswählen, CStr(DialogTitel))
           .ulFlags = &H1-> BIF_RETURNONLYFSDIRS
       End With
       
       ListenNr = SHBrowseForFolder(StrukturVerzeichnisInfo)
       Pfad = Space$(512)
       
       If SHGetPathFromIDList(ByVal ListenNr, ByVal Pfad) Then VerzeichnisWählen = Left(Pfad, InStr(Pfad, vbNullChar) - 1)
       
    End Function
    
    
    
    Public Sub FilesAusVerzeichnis_AuswertungMittelwert()
    'a) mit Auswahl des Pfades
    'b) mit Abfrage des Filters für Dateinamen (z.B. D*.TXT)
    'c) die Dateinamen suchen und merken
    'd) Die gemerkten Dateien werden geöffnet
    'e) Ergebnis workbook neu anlegen
    'f) neues Ergebnisblatt anlegen
    'g) 9 Mittelwert in Ergebnisblatt vermerken
    'h) 9 Mittelwert in Übersichtsblatt vermerken
    'i) Mittelwert in Ergebnisblatt
    'j) gemerkte Dateien werden geschlossen
    
    
    Dim fs As FileSearch
    Dim i As Long, z As Long, ret As Integer
    Dim sPath As String, sname As String, s_tmp As String
    Dim sSuchpfad As String, sFilename As String
    Dim f() As String, f_cnt As Long
    Dim dummy_StatistikErgebnisMittelwert As Double
    
    -> Auswahl des Pfades
     sSuchpfad = VerzeichnisWählen(Bitte wählen Sie das Verzeichnis)
    
     If sSuchpfad =  Then
       ret = MsgBox(Es wurde kein Suchpfad eingegeben ! & vbCrLf & Der Makro wird beendet., _
               vbOKOnly + vbInformation, Kein Suchpfad ausgewählt)
     Else
       
       'Wahl: Filename
       sFilename = InputBox(Geben Sie bitte den Filter für Filenamen ein !, Eingabe Filter Filname, *.*)
       If sFilename =  Then sFilename = *.*
    
       sPath = ActiveWorkbook.Path->Pfad des Dokuments
       sname = ActiveWorkbook.Name->Name des Dokuments
         
       'Feld initialisieren
       f_cnt = 0: ReDim f(1 To 1)
       
       'Filenamen aus dem Directory sPath auflisten
        Set fs = Application.FileSearch
        With fs
           .NewSearch
           .LookIn = sSuchpfad
           .FileName = sFilename
           i = .Execute(SortBy:=msoSortByFileName, SortOrder:=msoSortOrderAscending)
           If .FoundFiles.Count > 0 Then
             For i = 1 To .FoundFiles.Count
               If .FoundFiles(i) <> (sPath & \ & sname) Then->nicht dieses Dokument
                 s_tmp = .FoundFiles(i)
                 f_cnt = f_cnt + 1: ReDim Preserve f(1 To f_cnt)
                 f(f_cnt) = s_tmp
               End If
             Next i
           Else
             MsgBox Keine Dokumente gefunden
             Exit Sub
           End If
        End With
        
       ->wenn kein file vorhanden -> Ende
        If f_cnt > 0 Then
          Call ErgebnisseBilden(f(), f_cnt)
        End If
      End If
    End Sub
        
    Private Function NurFilenamen(s_vollstaendigerFilename As String) As String
    'schneidet die Pfadangaben aus einem String und gibt den Filenamen zurueck
    Dim p1 As Integer, p2 As Integer
    
     p2 = 0: p1 = 0
     Do
       p1 = InStr(p1 + 1, s_vollstaendigerFilename, \)
       If p1 <> 0 Then p2 = p1
     Loop While p1 <> 0
     NurFilenamen = Right(s_vollstaendigerFilename, Len(s_vollstaendigerFilename) - p2)
    End Function
    Sub ErgebnisseBilden(f() As String, f_cnt As Long)
        
      Dim wb_res As Workbook, ws_res As Worksheet, ws_erg As Worksheet
      Dim wb_akt As Workbook, ws_akt As Worksheet, y As Long
      Dim z As Long, i As Long, x As Long, sp As Long, s_tmp As String
      Dim r As Range, Zelle As Range
      
     ->Ergebnis-Workbook erzeugen
      Set wb_res = Workbooks.Add
     ->alle Blätter bis auf das erste löschen
      Application.DisplayAlerts = False
      Do While wb_res.Worksheets.Count > 1
        wb_res.Worksheets(wb_res.Worksheets.Count).Delete
      Loop
      Application.DisplayAlerts = False
      
     ->übriggebliebenes Blatt ist das Übersicht/Protokollblatt
      Set ws_res = Worksheets(Worksheets.Count)
      ws_res.Name = Übersicht
     ->Zeilenzähler für nächsten Eintrag initialisieren
      z = 1
     ->Überschriften
      ws_res.Cells(z, 1).Value = Statistikdaten 
      ws_res.Cells(z, 1).Font.Bold = True
      z = z + 1->Zeilenzaehler für naechsten Eintrag erhöhen
      ws_res.Cells(z, 1).Value = Filenamen: ws_res.Cells(z, 1).Font.Bold = True
      For i = 2 To 10
        ws_res.Cells(z, i).Value = Mittelwert & (i - 1)
        ws_res.Cells(z, i).Font.Bold = True
      Next
      z = z + 1->Zeilenzaehler für naechsten Eintrag erhöhen
      
      For i = 1 To f_cnt
        Application.StatusBar = f_cnt & / & i
       ->Dateien nacheinander öffnen
        s_tmp = f(i)->nächster Dateiname
       ->Datei öffnen
        On Error GoTo Error_OpenFile
        Set wb_akt = Workbooks.Open(f(i))
       ->ggf hier das Trennzeichen mit angeben
       ->z.B. Trennzeichen Tabstop
       ->Set wb_akt = Workbooks.Open(f(i),,,1)
       ->Format Trennzeichen:1 Tabstops :2 Kommas:3 Leerzeichen:4 Semikolons
        On Error GoTo 0
       ->aktuelles Blatt ist Inhalt der Werte-Datei
        Set ws_akt = ActiveSheet
       ->Ergebnis vermerken
        ws_res.Cells(z, 1).Value = NurFilenamen(s_tmp)
       ->9 Mittelwerte in Übersicht/Protokollblatt eintragen
        sp = 1
        For x = 0 To 2
          For y = 0 To 2
            sp = sp + 1
            Set r = ws_akt.Range(ws_akt.Cells(y * 32 + 1, x * 32 + 1), _
                                  ws_akt.Cells((y + 1) * 32, (x + 1) * 32))
            ws_res.Cells(z, sp).Value = Application.WorksheetFunction.Average(r)
          Next
        Next
       ->neues Blatt anlegen für Statistik-Daten
         Set ws_erg = wb_res.Worksheets.Add(After:=wb_res.Worksheets(wb_res.Worksheets.Count))
       ->9 Werte + Mittelwert auf neues Blatt übertragen
        ws_erg.Name = Erg & i
       ->Werte aus dem Übersichtsblatt in neues Blatt übertragen
        For x = 1 To 9
          ws_erg.Cells(1, x).Value = ws_res.Cells(z, x + 1).Value
        Next
    
       ->Werte-Datei schliessen
        wb_akt.Close SaveChanges:=False
        
       ->Zeilenzaehler für naechsten Eintrag erhöhen
       ->auf Übersichtsblatt
        z = z + 1
      Next i
      ws_res.Activate
    
    Aufraeumen:
     On Error Resume Next
     Set wb_res = Nothing: ws_res = Nothing: Set ws_erg = Nothing
     Set wb_akt = Nothing: ws_akt = Nothing
     On Error GoTo 0
     Application.StatusBar = 
     Exit Sub
    Error_OpenFile:
      Err.Clear
      MsgBox (Das file  & s_tmp &  konnte nicht geöffnet werden.)
      GoTo Aufraeumen
    End Sub
     
Die Seite wird geladen...

Excel Makro - HILFE! - Ähnliche Themen

Forum Datum
Excel VBA Makro zum suchen eines Textes und anschließend einen Breich zu kopieren Microsoft Office Suite 22. Jan. 2015
Excel VBA Makro zum suchen und markieren von Zeilen die ein bestimmtes Wort enthalten Microsoft Office Suite 16. Juni 2014
Excel: Makro ASCII verschieben Windows XP Forum 8. Nov. 2013
Makros und anderes - Excel Microsoft Office Suite 15. März 2013
Excel Sprungmarke mitten in ein anderes Makro Windows XP Forum 15. März 2012