Schleifen verschachteln

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Sepp, Hallo VBA-Freaks,
hier der Code, ich habe heute noch ein bisschen gebastelt.
Das hier ist dabei rausgekommen:


Sub Test2()
Dim i As Integer
Dim v As String
Dim z As Integer
Workbooks("Toleranzen S2.xls").Activate
Sheets("Variablen").Select
For z = 2 To ActiveSheet.UsedRange.Rows.Count
Range("A1").Select
ActiveCell.Offset(z, 0).Select
v = ActiveCell.Value
Workbooks("Protokolle.xls").Activate
For i = 1 To ActiveWorkbook.Sheets.Count
Workbooks("Protokolle.xls").Activate
Sheets(i).Activate
Cells.Find(What:=v, After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, searchorder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
On Error Resume Next
ActiveCell.Offset(0, 3).Select
ActiveCell.Copy
Workbooks("Toleranzen S2.xls").Activate
Sheets("Variablen").Select
ActiveCell.Offset(0, 1).Select
ActiveSheet.Paste
Next i
Next z
End Sub

In dem Workbook "Protokolle" habe ich die eingefügten Protokolle.
Die Auswertung würde ich gern über Teilergebnis in dem Workbook "Toleranzen" machen.
Ich hab gerade versucht mal 86 Protokolle über obiges Makro einzufügen.
das hat sage und schreibe 12 min gedauert, für ca. 8000 Daten (ca 96 Variablen * 86 Werte). Ist das normal oder kann man das schneller machen. Vielleicht ist meine Methode nicht die richtige, kann man vielleicht mehrere Daten in den speicher lesen und dann in ein Tabellenblatt einfügen ? Falls ihr noch Infos braucht, bitte nachfragen.
Gruß
Stefan

Hallo Stefan!
Ich hatte mehrere Fundstellen in verschiedenen Sheets nicht beachtet.

Sub Test2()
Dim objSh As Worksheet, objShSrc As Worksheet
Dim lngLast As Long, lngR As Long
Dim intC As Integer
Dim rng As Range

On Error GoTo ErrExit

With Application
  .ScreenUpdating = False
  .EnableEvents = False
  .DisplayAlerts = False
  .Calculation = xlCalculationManual
  .Cursor = xlWait
End With

Set objShSrc = Workbooks("Toleranzen S2.xls").Sheets("Variablen")

With objShSrc

  lngLast = .Cells(Rows.Count, 1).End(xlUp).Row

  For lngR = 2 To lngLast
    intC = 2
    For Each objSh In Workbooks("Protokolle.xls").Worksheets
      Set rng = objSh.Cells.Find(What:=.Cells(lngR, 1), _
        LookIn:=xlFormulas, _
        LookAt:=xlPart)

      If Not rng Is Nothing Then
        rng.Offset(0, 3).Copy .Cells(lngR, intC)
        intC = intC + 1
      End If
    Next
  Next

End With

ErrExit:

If Err.Number > 0 Then
  MsgBox Err.Number & vbLf & Err.Description, , "Fehler"
  Err.Clear
End If

With Application
  .ScreenUpdating = True
  .EnableEvents = True
  .DisplayAlerts = True
  .Calculation = xlCalculationAutomatic
  .Cursor = xlDefault
End With

Set objShSrc = Nothing

End Sub

Gruß Sepp

Beliebteste Forumthreads (12 Monate)

10 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

10
Beiträge zum Forumthread

Beiträge zu diesem Forumthread