Hi,

Schau doch mal, ob Du etwas aus dieser Datei für Dich verwenden kannst.

btw: Datum
Was heisst das genau?
Heisst das im Bereich können in den Zellen B10 bis B.... immer unterschiedliche Jahreszahlen stehen? Oder ist das pro Quelldatei immer nur ein und dieselbe Jahreszahl?

Bye
malSchauen

Hi,

.... da brauche ich ja Stunden zum durchwühlen ;-))))

Aber grundsätzlich funktioniert es schonmal - außer der Tatsache, dass die Werte aus C3, C4, C5 und C6 nur einmal pro Tabelle übertragen werden.

In der Spalte B kommen übrigens die Jahre 2008 und 2009 vor, die Trennung der Jahre muss nicht zwingend sein (ich habe mir nur gedacht, dass das Makro schneller ausgeführt wird wenn weniger Daten zu suchen sind ??)

Ich habe mal 2 Tabellen (1.xls und Behandlungen.xls) online gestellt, daraus wird dann - so hoffe ich - ersichtlich was ich meine....

Tabelle 1.xls

http://www.file-upload.net/download-1923734/1.xls.html

Tabelle Behandlungen.xls

http://www.file-upload.net/download-1923730/MB_Behandlungen.xls.html

Vielen Dank schonmal ....

Gruss - Petra

Hallo Petra,

nachfogendes Makro kopiert Dir die Daten aller Dateien in einem Pfad in Deine Übersichtsdatei.

Kopiere das Makro in Deine Datei "MB_Behandlungen.xls" in ein StandardModul und starte es z.B. über eine Befehlsschaltfläche.
Teste das Makro aber bitte in einer Testdatei und nicht gleich in Deiner Originaldatei.

Option Explicit

Const strPath = "C:\Eigene Dateien"

Sub Dateien_auslesen()
Dim Datei$
Dim lngFirstRow As Long
Dim lngLastRow As Long
Dim lngCopyRow As Long

Datei = Dir(strPath & "\*.xls")
Do While Datei <> ""
    If Right(Datei, 4) = ".xls" Then
        GetObject (strPath & "\" & Datei)
        lngFirstRow = ActiveSheet.Cells(Rows.Count, 2).End(xlUp).Offset(1, 0).Row
        lngLastRow = Workbooks(Datei).Sheets(1).Cells(Rows.Count, 2).End(xlUp).Row
        lngCopyRow = lngFirstRow + (lngLastRow - 10)
        
        With Workbooks(Datei).Sheets(1)
            'Behandlungsdaten
            .Range("B10:H" & lngLastRow).Copy ActiveSheet.Cells(lngFirstRow, 5)
            'Kundenummer
            ActiveSheet.Range("A" & lngFirstRow & ":A" & lngCopyRow) = .Range("C3")
            'Nachname
            ActiveSheet.Range("B" & lngFirstRow & ":B" & lngCopyRow) = .Range("C4")
            'Vorname
            ActiveSheet.Range("C" & lngFirstRow & ":C" & lngCopyRow) = .Range("C5")
            'Abrechnung
            ActiveSheet.Range("D" & lngFirstRow & ":D" & lngCopyRow) = .Range("C6")
        End With
        
        Workbooks(Datei).Close
    End If
    Datei = Dir()
Loop
End Sub

In dem Makro musst Du in der Zeile

Const strPath = "C:\Eigene Dateien"

noch den Pfad, in dem sich die auszulesenden Dateien, anpassen.

Solltest Du nicht wissen, wie Du den Code in Deine Datei bekommst, dann schau mal auf meiner HP in der Rubrik Anleitungen und dort dann in der Anleitungsnummer 3 nach. Dort stelle ich dazu eine bebilderte Anleitung zur Verfügung, die Dir sicherlich helfen wird.

Bei Fragen melde Dich.

MfG,
Oliver
_{Da hier der einzige Lohn für die Helfer eine Rückmeldung ist, wäre es nett, wenn Du}
^{ein Feedback abgeben könntest, ob der Lösungsvorschlag Dein Problem gelöst hat.}

Hi,

sieht schon super gut aus, ansich funktioniert es einwandfrei, allerdings sind nun 2 neue Probleme aufgetaucht:

1. Excel wackelt ;-)) fürchterlich ... man sieht also, dass etwas passiert, ich habe Application.DisplayAlerts = False eingefügt ... doch garantiert wieder an der falschen Stelle ...

2. Es werden auch leere Datensätze übernommen (das hatte ich vorher gar nicht bedacht). Es existieren Tabellen, in denen keine Daten vorhanden sind, diese brauchen dann ja auch gar nicht übertragen werden.
Also brauche ich eine If-Abfrage ... mein Ansatz wäre
If ActiveSheet.Range("B10") = "" Then
doch dann?? es soll ja kein Abbruch erfolgen??


Hier der geänderte Code:

Option Explicit

Const strPath = "C:\Users\Petra\Desktop\Behandlungen"

Sub Dateien_auslesen()
Dim Datei$
Dim lngFirstRow As Long
Dim lngLastRow As Long
Dim lngCopyRow As Long

[A5:k65000] = "" 'Alte Eintragungen löschen

Datei = Dir(strPath & "\*.xls")
Application.AskToUpdateLinks = False 'deaktiviert Aktualisierung

Do While Datei <> ""
Application.DisplayAlerts = False 'HIER oder WO ???

If Right(Datei, 4) = ".xls" Then
GetObject (strPath & "\" & Datei)
lngFirstRow = ActiveSheet.Cells(Rows.Count, 2).End(xlUp).Offset(1, 0).Row
lngLastRow = Workbooks(Datei).Sheets(1).Cells(Rows.Count, 2).End(xlUp).Row
lngCopyRow = lngFirstRow + (lngLastRow - 10)

With Workbooks(Datei).Sheets(1)
If ActiveSheet.Range("B10") = "" Then
'??????? .Range("B10:H" & lngLastRow).Copy ActiveSheet.Cells(lngFirstRow, 5) 'Behandlungsdaten
ActiveSheet.Range("A" & lngFirstRow & ":A" & lngCopyRow) = .Range("C3") 'Kundennummer
ActiveSheet.Range("B" & lngFirstRow & ":B" & lngCopyRow) = .Range("C4") 'Nachname
ActiveSheet.Range("C" & lngFirstRow & ":C" & lngCopyRow) = .Range("C5") 'Vorname
ActiveSheet.Range("D" & lngFirstRow & ":D" & lngCopyRow) = .Range("C6") 'Abrechnung
End With

Workbooks(Datei).Close
End If
Datei = Dir()
Loop
Application.DisplayAlerts = True
End Sub

... ähm wie blöd ....

habe zum Abschalten des Bildschirms den falschen Code angewendet, mit Application.ScreenUpdating = False funktioniert es einwandfrei ..

bleibt also noch 1 Problem ;-)


Gruss - Petra

Hallol,

perfekt, nun funkzt es einwandfrei .....

Aber mal noch eine Frage zum Verständnis:

In der Zeile If Right(Datei, 4) = ".xls" Then WOFÜR ist
die 4 ??

Vielen, vielen Dank ;-))


Gruss - Petra

Hallo Petra,

gerne geschehen. Die Zahl 4 steht für 4 Buchstaben. Also wenn der Dateiname von rechts gelesen mit 4 Buchstaben den Text ".xls" ergibt dann....

Danke auch für die Rückmeldung.

So, ich schau dann mal weiter Formel1.

MfG,
Oliver
_{Da hier der einzige Lohn für die Helfer eine Rückmeldung ist, wäre es nett, wenn Du}
^{ein Feedback abgeben könntest, ob der Lösungsvorschlag Dein Problem gelöst hat.}

Hi,

@Petra65


Stimmt auffallend. Das was bei mir da im VBA-Editor landet, ist zwar meist funktionsfähig, aber wie ich zugeben muss, sehr schlecht zu lesen und zu pflegen. Da habe ich noch sehr viel zu üben und zu lernen. Da ist der Code von Coros doch deutlich besser strukturiert/aufgebaut.

Wie es auch sei, Dir wurde von Coros geholfen, und dadurch dass ich für mich das Problem durchdacht habe, kann auch ich anhand des Codes von Coros weiter lernen, wie man entsprrechenden Code aufbauen und strukturieren kann.

Also nichts für ungut...
malSchauen

Hi malSchauen,



Das, was bei mir im VBA-Editor landet (abgesehen von Code-Aufzeichnungen) funktioniert meist leider nicht !!! Ich drehe mich stets im Kreis und finde den Lösungsansatz nicht ;-(

Sei froh, dass Deine Codes, wenn auch etwas unübersichtlich, funktionieren ;-)

Viele Grüße - Petra

Hallo, guten Morgen,

ich muss leider die Frage nochmals nach oben holen, da der Code aus Antwort 6 folgendes nicht berücksichtigt:

Es kann sein, dass in A10 eine 1 steht, aber in A11 eine 2.

Ich möchte nun, dass die Daten folgendermassen übertragen werden, z. B. wenn
B10 <> 0 UND A10 = 1 -> übertragen
B11 <> 0 UND A11 = 2 -> nicht übertragen
usw.

Das Problem ist (so glaube ich), dass der Code nur B10 auf ungleich Null abfängt (ist also B10 ungleich Null, so werden ALLE Daten übertragen).
Ich weiss nun nicht wie kompliziert es ist den Code zu ändern.

Ich hoffe auf Denkanstösse ;-)

Gruss - Petra

hi malSchauen und der rest der welt ^^

hier ein highlight fuer dich und alle anderen motivierten vb freaks *hihi*

gruss nighty

VBAHTML 2.0.0.0 alpha 2 von Lukas Mosimann

ein addinn zum einruecken des codes *mein liebling hrhrrr*

hier der link

http://vbahtml.origo.ethz.ch/download

Hallo Petra,

Du gibst Dir die Antwort doch bereits selber in Deiner Datei mit Deiner Aussage


Dann änbdere doch auch die Zeile

If Workbooks(Datei).Sheets(1).Range("B10") <> 0 Then

in

If Workbooks(Datei).Sheets(1).Range("B10") <> 0 And Workbooks(Datei).Sheets(1).Range("A10") = 1 Then

MfG,
Oliver
_{Da hier der einzige Lohn für die Helfer eine Rückmeldung ist, wäre es nett, wenn Du}
^{ein Feedback abgeben könntest, ob der Lösungsvorschlag Dein Problem gelöst hat.}

Hi,

Ich glaube ja eher, Petra meint das Zeile für Zeile. Also aus der .Range("B10:H" & lngLastRow) nur die Zeilen zu kopieren, die in SpalteA eine 1 stehen haben. Wenn das so ist, könnte das funktionieren wie folgt (Code aus AW6 abgeändert):

Sub Dateien_auslesen()
Dim Datei$
Dim lngFirstRow As Long
Dim lngLastRow As Long
Dim lngCopyRow As Long
Dim lngCount As Long
Application.ScreenUpdating = False

Datei = Dir(strPath & "\*.xls")
Do While Datei <> ""
    If Right(Datei, 4) = ".xls" Then
        GetObject (strPath & "\" & Datei)
        If Workbooks(Datei).Sheets(1).Range("B10") <> 0 Then
            lngFirstRow = ActiveSheet.Cells(Rows.Count, 2).End(xlUp).Offset(1, 0).Row
            lngLastRow = Workbooks(Datei).Sheets(1).Cells(Rows.Count, 2).End(xlUp).Row
            lngCopyRow = 0
            
            With Workbooks(Datei).Sheets(1)
                For lngCount = 10 To lngLastRow
                  If .Range("A" & lngCount).Value = 1 Then
                    'Behandlungsdaten
                    .Range("B" & lngCount & ":H" & lngCount).Copy _
                    ActiveSheet.Cells(lngFirstRow + lngCopyRow, 5)
                    lngCopyRow = lngCopyRow + 1
                  End If
                Next
                lngCopyRow = lngCopyRow + lngFirstRow - 1
                'Kundenummer
                ActiveSheet.Range("A" & lngFirstRow & ":A" & lngCopyRow) = .Range("C3")
                'Nachname
                ActiveSheet.Range("B" & lngFirstRow & ":B" & lngCopyRow) = .Range("C4")
                'Vorname
                ActiveSheet.Range("C" & lngFirstRow & ":C" & lngCopyRow) = .Range("C5")
                'Abrechnung
                ActiveSheet.Range("D" & lngFirstRow & ":D" & lngCopyRow) = .Range("C6")
            End With
        End If
        Workbooks(Datei).Close
    End If
    Datei = Dir()
Loop
Application.ScreenUpdating = True
End Sub

bye
malSchauen

Hi,

Noch eine Änderung für den Fall, dass alle Behandlungen in der Quelle der Kategorie2 zugehören. (B10 ist nicht leer, aber es wird auch nichts kopiert.) Dann dürfen nat. keine Kundendaten übertragen werden.

.
.
.
                Next
                If lngCopyRow > 0 Then         ' wenn mindestens eine Zeile kopiert
                  lngCopyRow = lngCopyRow + lngFirstRow - 1
                  'Kundenummer
                  ActiveSheet.Range("A" & lngFirstRow & ":A" & lngCopyRow) = .Range("C3")
                  'Nachname
                  ActiveSheet.Range("B" & lngFirstRow & ":B" & lngCopyRow) = .Range("C4")
                  'Vorname
                  ActiveSheet.Range("C" & lngFirstRow & ":C" & lngCopyRow) = .Range("C5")
                  'Abrechnung
                  ActiveSheet.Range("D" & lngFirstRow & ":D" & lngCopyRow) = .Range("C6")
                End If
            End With
.
.
.

bye
malSchauen

Hi,

Ich habe oben stehenden Code in einer Testdatei getestet, seither erhalte ich selbst bei Makros - die bisher fehlerfrei funktionierten - folgende Fehlermeldung:

Laufzeitfehler 1004
Die Methode 'Rows' für das Objekt '_Global" ist fehlgeschlagen

Diese Makros enthalten ALLE folgende Codezeile, die als fehlerhaft angezeigt wird:
lngFirstRow = ActiveSheet.Cells(Rows.Count, 2).End(xlUp).Offset(1, 0).Row

Und alle Dateien liegen im selben Ordner, Sicherungsdateien (andere Ordner) der letzten Tage funktionieren fehlerlos.

Ich stelle nun erstmal den letzen funktionierenden Zustand her ... melde mich aber auf jeden Fall nochmal - kann etwas dauern ;-)

Bisher erstmal vielen Dank für Eure Hilfe


Gruss - Petra

Hi,

Sollte der von mir abgeänderte Code aus AW14&15 dafür verantwortlich sein, dann bitte ich um Entschuldigung. Ich kann es mir aber nicht erklären, wie das zustande kommen kann. Evtl. kann mich jemand der hier noch mitliest und dieses Problem identifizieren kann über die Ursache/den Fehler in meinem Code aufklären.
Führt denn evtl. eine CodeZeile die mit "_" auf die folgende Zeile verlängert wird, beim Kopieren hier aus dem Forum zu einem solchen Problem? Ich habe es versucht das Problem hier nachzustellen, aber nach dem Einfügen läuft es klaglos, sodass ich den Fehler nicht nachvollziehen kann.

Petra: So Du Dich noch traust Code aus meinen Postings zu verwenden, so folgt hier, für den Fall dass es tatsächlich daran liegen sollte, nocheinmal das Makro ohne "Zeilenerweiterung" bei 'Behandlungsdaten:

Option Explicit

Const strPath = "C:\Eigene Dateien"

Sub Dateien_auslesen()
Dim Datei$
Dim lngFirstRow As Long
Dim lngLastRow As Long
Dim lngCopyRow As Long
Dim lngCount As Long

Application.ScreenUpdating = False

Datei = Dir(strPath & "\*.xls")
Do While Datei <> ""
  If Right(Datei, 4) = ".xls" Then
    GetObject (strPath & "\" & Datei)
    If Workbooks(Datei).Sheets(1).Range("B10") <> 0 Then
      lngFirstRow = ActiveSheet.Cells(Rows.Count, 2).End(xlUp).Offset(1, 0).Row
      lngLastRow = Workbooks(Datei).Sheets(1).Cells(Rows.Count, 2).End(xlUp).Row
      lngCopyRow = 0
      
      With Workbooks(Datei).Sheets(1)
        For lngCount = 10 To lngLastRow
          If .Range("A" & lngCount).Value = 1 Then
            'Behandlungsdaten
            .Range("B" & lngCount & ":H" & lngCount).Copy ActiveSheet.Cells(lngFirstRow + lngCopyRow, 5)
            lngCopyRow = lngCopyRow + 1
          End If
        Next
        If lngCopyRow > 0 Then         ' wenn mindestens eine Zeile kopiert
          lngCopyRow = lngCopyRow + lngFirstRow - 1
          'Kundenummer
          ActiveSheet.Range("A" & lngFirstRow & ":A" & lngCopyRow) = .Range("C3")
          'Nachname
          ActiveSheet.Range("B" & lngFirstRow & ":B" & lngCopyRow) = .Range("C4")
          'Vorname
          ActiveSheet.Range("C" & lngFirstRow & ":C" & lngCopyRow) = .Range("C5")
          'Abrechnung
          ActiveSheet.Range("D" & lngFirstRow & ":D" & lngCopyRow) = .Range("C6")
        End If
      End With
    End If
    Workbooks(Datei).Close
  End If
  Datei = Dir()
Loop
Application.ScreenUpdating = True

End Sub

bye
malSchauen

Hi malSchauen,



Na klar ... immer her damit ;-)))

Mach Dir mal keinen "Kopf" ob es an dem Code lag .... das Risiko liegt ja wohl bei mir !! !!
Ich bin ja unheimnlich froh wenn ich hier Hilfe bekomme - alleine könnte ich das niemals lösen.

Aber was anderes: Dein Code funktioniert super gut ;-) ...
Vielen vielen Dank dafür

Gruss - Petra