Excel Makro - HILFE!

  • #1
U

Unwissender

Guest
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
 
Thema:

Excel Makro - HILFE!

ANGEBOTE & SPONSOREN

Neueste Themen

Statistik des Forums

Themen
113.840
Beiträge
707.963
Mitglieder
51.494
Neuestes Mitglied
Flensburg45
Oben