Microsoft Excel

Herbers Excel/VBA-Archiv

Makro - einfache VBA Schleife für Excel | Herbers Excel-Forum


Betrifft: Makro - einfache VBA Schleife für Excel von: pc-doc@k-u-p.de
Geschrieben am: 20.10.2008 11:51:38

Hallo VBA MAkro Profis,

programmiere fast nie in VBA mehr Web js, php/mysql,
und brauche eine einfache VBA Schleife für Excel:
Ich möchte in mehreren Registerblättern einer Arbeitsmappe in der
Spalte D Zeile für Zeile checken ob
ein Wert in der Zelle steht
und wenn er existiert
ob er zwischen zB 1 und 3 ist

wenn true dann soll die ganze Zeile kopiert
und im Ziel/Übersichtsregisterblatt unterhalb der letzten Zeile eingefügt werden usw...

false einfach weiter in der Schleife

vielen Dank für Hilfe
Rainer

  

Betrifft: AW: Makro - einfache VBA Schleife für Excel von: JogyB
Geschrieben am: 20.10.2008 12:07:27

Ich habe mal das Übersichtssheet als Tabellenblatt 1 angenommen und bin von einer Überschrift in jedem Tabellenblatt ausgegangen. Der Code kann in die Arbeitsmappe, muss aber nicht. Die Übersicht wird bei jeder Ausführung komplett neu aufgebaut.

Sub ueberTragen()

Dim blaTT As Byte
Dim leseZeiLe As Long
Dim schreibZeile As Long
Dim overVSh As Worksheet
Dim readSh As Worksheet
    
    Application.ScreenUpdating = False
    schreibZeile = 2
    Set overVSh = ActiveWorkbook.Sheets(1)
    
    For blaTT = 2 To ActiveWorkbook.Sheets.Count
        Set readSh = ActiveWorkbook.Sheets(blaTT)
        For leseZeiLe = 2 To readSh.Cells(Rows.Count, 4).End(xlUp).Row
            If IsNumeric(readSh.Cells(leseZeiLe, 4).Value) Then
                If readSh.Cells(leseZeiLe, 4).Value <= 3 And readSh.Cells(leseZeiLe, 4).Value >= _
 1 Then
                    readSh.Rows(leseZeiLe).Copy overVSh.Rows(schreibZeile)
                    schreibZeile = schreibZeile + 1
                End If
            End If
        Next
    Next
    Application.ScreenUpdating = True
End Sub


Gruss, Jogy


  

Betrifft: AW: Makro - einfache VBA Schleife kleine Änderung von: pc-doc@k-u-p.de
Geschrieben am: 20.10.2008 15:20:11

VIELEN DANK FÜR die Beispielmakros - das von JogyB lief sofort - bei
jetzt hat sich noch eine kleine Änderung/Erweiterung eingeschlichen:

Die Quell-Arbeitsblätter sind in einzelnen Exceldateien mit jeweils einem ArbeitsBlatt.

Dh. ich öffne die gewünschten Quellexceldateien in einem Excelfenster und würde dann gerne über die geöffneten Worksheets der XLS-Dateien das Makro suchen lassen... kann man das auch entsprechend realisieren ?
oder alle xls-Dateien in einem bestimmten Ordner
oder ein Array mit Namen der Exceldateien?

Dank & Güße Rainer


  

Betrifft: AW: Makro - einfache VBA Schleife kleine Änderung von: JogyB
Geschrieben am: 20.10.2008 16:06:31

Hallo.

Damit kannst Du die Arbeitsmappen in einem Öffnen-Dialog auswählen.

Es schreibt in das aktive Tabellenblatt.

Sub ueberTragen2()


Dim wbkNr As Byte
Dim leseZeiLe As Long
Dim schreibZeile As Long
Dim readWbk As Workbook
Dim daTeien As Variant
Dim overVSh As Worksheet
    
    Application.ScreenUpdating = False
    schreibZeile = 2
    Set overVSh = ActiveSheet
    
    daTeien = Application.GetOpenFilename("Excel-Dateien (*.xls), *.xls", , "Dateien auswählen", _
 , True)
    
    ' Wenn kein Array, dann wurde Abbrechen gedrückt
    If Not IsArray(daTeien) Then Exit Sub
    
    For wbkNr = 1 To UBound(daTeien)
        Set readWbk = Workbooks.Open(daTeien(wbkNr), , True)
        With readWbk.Sheets(1)
            For leseZeiLe = 2 To .Cells(Rows.Count, 4).End(xlUp).Row
                If IsNumeric(.Cells(leseZeiLe, 4).Value) Then
                    If .Cells(leseZeiLe, 4).Value <= 3 And .Cells(leseZeiLe, 4).Value >= 1 Then
                        .Rows(leseZeiLe).Copy overVSh.Rows(schreibZeile)
                        schreibZeile = schreibZeile + 1
                    End If
                End If
            Next
        End With
        readWbk.Close False
    Next
    Application.ScreenUpdating = True
    
End Sub


Gruss, Jogy


  

Betrifft: @JogyB AW: Makro - einfache VBA Schleife von: pc-doc@k-u-p.de
Geschrieben am: 20.10.2008 16:42:56

@Jogy

Nochmals vielen Dank ,
ich würde gerne die Varianten
alle Dateien(Dateinamen) eines Ordners (ohne die Übersichtsdatei) in ein Array lesen und abarbeiten
und
Die xls-Quell-DatenDateien (Pfad/Name) explizit im Makro festlegen

noch beispielhaft durchspielen?

Im Moment ist noch nicht ganz geklärt, wo die Dateien liegen und was passiert, wenn eine gerade göffnet ist, wenn mein MAkro darauf zugreift

Da das so langsam in Arbeit ausartet bin ich gerne bereit eine kleine Aufwandsentschädigung
zu spenden ...

Gürße
Rainer


  

Betrifft: @JogyB AW: Makro - einfache VBA Schleife von: JogyB
Geschrieben am: 20.10.2008 17:14:38

Hi.

Zum einlesen fallen mir spontan zwei Möglichkeiten ein, entweder über Dir oder über FileSearch. Ich nehme mal FileSearch, weil Du damit noch die Möglichkeit hättest, auch die Dateien von Unterordnern zu verwenden.

Sub ueberTragen3()

Dim wbkNr As Byte
Dim leseZeiLe As Long
Dim schreibZeile As Long
Dim readWbk As Workbook
Dim daTeien As Variant
Dim overVSh As Worksheet
Dim overVWbk As Workbook
Dim offSet As Long
Const sPath = "c:\temp\" ' Hier den Suchpfad eintragen
    
    Application.ScreenUpdating = False
    schreibZeile = 2
    Set overVSh = ActiveSheet
    Set overVWbk = ActiveWorkbook
    
    With Application.FileSearch
        .Filename = "*.xls"
        .LookIn = sPath
        .SearchSubFolders = False ' oder True, wenn Du in Unterordnern suchen willst
        .Execute
        
        If .FoundFiles.Count > 0 Then
            ReDim daTeien(1 To .FoundFiles.Count)
                
            For wbkNr = 1 To .FoundFiles.Count
                If .FoundFiles(wbkNr) <> overVWbk.FullName Then
                    daTeien(wbkNr - offSet) = .FoundFiles(wbkNr)
                Else
                    ReDim Preserve daTeien(1 To UBound(daTeien) - 1)
                    offSet = offSet + 1
                End If
            Next
        Else
            Exit Sub
        End If
    End With
 
    
    For wbkNr = 1 To UBound(daTeien)
        Set readWbk = Workbooks.Open(daTeien(wbkNr), , True)
        With readWbk.Sheets(1)
            For leseZeiLe = 2 To .Cells(Rows.Count, 4).End(xlUp).Row
                If IsNumeric(.Cells(leseZeiLe, 4).Value) Then
                    If .Cells(leseZeiLe, 4).Value <= 3 And .Cells(leseZeiLe, 4).Value >= 1 Then
                        .Rows(leseZeiLe).Copy overVSh.Rows(schreibZeile)
                        schreibZeile = schreibZeile + 1
                    End If
                End If
            Next
        End With
        readWbk.Close False
    Next
    Application.ScreenUpdating = True
    
End Sub


Die Übertragung in den Dateien-Array ist eigentlich unnötig, so konnte ich aber den restlichen Code unverändert lassen.

Geöffnete Dateien sind übrigens kein Problem, da die Dateien schreibgeschützt geöffnet werden. Das einzige Problem wäre, wenn die Dateien von Dir bereits geöffnet wären. Könnte man aber auch noch abfangen, wenn Dir das wichtig wäre.
Ein weiteres Problem wäre, wenn bereits eine andere Datei mit demselben Dateinamen bei Dir offen wäre - kann man auch abfangen, nur was soll dann mit der bereits geöffneten Datei passieren?

Gruss, Jogy


  

Betrifft: AW: Makro - einfache VBA Schleife für Excel von: Erich G.
Geschrieben am: 20.10.2008 12:16:25

Hallo Rainer,
deine Aufgabenstellung lässt noch einige Fragen offen.

Kleine Vorab-Bemerkung:
"Registerblätter" gibts nicht, die heißen Tabellenblätter, die im Blattregister aufgelistet sind.

- Heißt "in mehreren Registerblättern" in allen Tabellenblättern außer dem Blatt "Ziel"?
Oder nur in bestimmten Blättern - die könnte man dann z. B. als Array vorgeben.

- Stehen nur Zahlen in Spalte D der Blätter? Auch in Zeile 1, wo oft Überschriften/Spaltenbezeichnungen stehen?

- Heißt "zwischen 1 und 3", dass auch Zeilen mit Wert 1 oder 3 kopiert werden sollen?

Hier das Ergebnis meiner Annahmen:

Option Explicit

Sub Check_D()
   Dim wksZ As Worksheet, lngZ As Long, wksS As Worksheet, zz As Long
   
   Set wksZ = Worksheets("Ziel")
   lngZ = wksZ.Cells(wksZ.Rows.Count, 4).End(xlUp).Row
   
   For Each wksS In Worksheets
      With wksS
         If .Name <> wksZ.Name Then
            For zz = 1 To .Cells(.Rows.Count, 4).End(xlUp).Row
               If 1 <= .Cells(zz, 4) And .Cells(zz, 4) <= 3 Then
                  lngZ = lngZ + 1
                  .Rows(zz).Copy wksZ.Cells(lngZ, 1)
               End If
            Next zz
         End If
      End With
   Next wksS
End Sub

Rückmeldung wäre nett! - Grüße von Erich aus Kamp-Lintfort


  

Betrifft: AW: Makro - einfache VBA Schleife für Excel von: Tino
Geschrieben am: 20.10.2008 13:39:30

Hallo,
hier mal eine Möglichkeit.
Es wird in allen Tabellen in Spalte D nach gesehen außer in der Tabelle Ziel.
Wird ein Wert gefunden der >=1 oder <=3 ist, wird die Spalte D nach Ziel in Spalte A kopiert.
Es werden nur Zahlen in die Prüfung einbezogen keine Texte, also auch keine Texte die wie eine Zahl aussehen.

Option Explicit

Sub TestMakro()
Dim i As Integer
Dim objR As Range

Application.ScreenUpdating = False
For i = 1 To ThisWorkbook.Sheets.Count

    With Sheets(i)
        If .Name <> "Ziel" Then
         
         Set objR = .Range("D1", .Cells(.Rows.Count, "D").End(xlUp))
          
          With Application.WorksheetFunction
           If .Count(objR) - .CountIf(objR, "<1") - .CountIf(objR, ">3") > 0 Then
            
            With Sheets("Ziel")
             objR.Copy .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0)
            End With
           
           End If
          
          End With
        
        End If
    End With
Next i
Application.ScreenUpdating = True
End Sub



Gruß Tino


Beiträge aus den Excel-Beispielen zum Thema "Makro - einfache VBA Schleife für Excel"