VBA - Suchen und aufaddieren

Bild

Betrifft: VBA - Suchen und aufaddieren von: Günter
Geschrieben am: 05.02.2005 18:07:53

Guten Tag,

wer hat eine Idee für folgendes Thema:

Ich habe eine Exceldatei (siehe Anhang), in welcher auf dem Tabellenblatt2
eine Zählung aus dem Tabellenblatt 1 gemacht werden sollte.
Eine Beispieldatei habe ich im Anhang angehängt.

https://www.herber.de/bbs/user/17516.xls

Diese Datei ist im Normalfall um die 30000 Einträge groß.

Verzwickt..

Gruss
Günter

Bild


Betrifft: AW: VBA - Suchen und aufaddieren von: Josef Ehrensberger
Geschrieben am: 05.02.2005 18:45:26

Hallo Günter!

Diesr Code sollte es tun.


      
Option Explicit

Sub Buchabschnitte()
Dim wksQ As Worksheet
Dim wksZ As Worksheet
Dim iCol As Integer
Dim lRow As Long, lastRow As Long
Dim rng As Range
Dim sFirst As String

On Error GoTo ERRORHANDLER

Set wksQ = Sheets("Tabelle1"'Tabelle mit den Buchabschnitten
Set wksZ = Sheets("Tabelle2"'Tabelle mit der Auflistung

lastRow = IIf(wksQ.Range(
"A65536") <> "", 65536, wksQ.Range("A65536").End(xlUp).Row)

iCol = 2
lRow = 1

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


Set rng = wksQ.Range("A1:A" & lastRow).Find(What:="[", after:=wksQ.Range("A" & lastRow))

   
If Not rng Is Nothing Then
   sFirst = rng.Address
      
Do
      wksZ.Cells(lRow, iCol) = rng
      wksZ.Cells(lRow + 2, iCol) = rng.Offset(8, 2)
      wksZ.Cells(lRow + 3, iCol) = rng.Offset(10, 2)
      wksZ.Cells(lRow + 4, iCol) = rng.Offset(8, 2) + rng.Offset(10, 2)
      wksZ.Cells(lRow + 6, iCol) = rng.Offset(13, 2)
      wksZ.Cells(lRow + 7, iCol) = rng.Offset(15, 2)
      wksZ.Cells(lRow + 8, iCol) = rng.Offset(13, 2) + rng.Offset(15, 2)
      iCol = iCol + 1
         
If iCol > 256 Then
         iCol = 2
         lRow = lRow + 10
         wksZ.Range(
"A1:A9").Copy wksZ.Cells(lRow, 1)
         
End If
      
Set rng = wksQ.Range("A1:A" & lastRow).FindNext(rng)
      
Loop While rng.Address <> sFirst
   
End If
   
wksZ.Columns.AutoFit

ERRORHANDLER:

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

End Sub 


     Code eingefügt mit Syntaxhighlighter 3.0



Gruß Sepp

P.S.: Rückmeldung nicht vergessen!


Bild


Betrifft: AW: VBA - Suchen und aufaddieren von: Ulf
Geschrieben am: 05.02.2005 18:51:57

Set rng = wksQ.Range("A1:A" & lastRow).Find(What:="[", after:=wksQ.Range("A" & lastRow))

ist bei Find nicht nötig, weils Null Geschwindigkeitsgewinn bringt.

Somit kann auch

lastRow = IIf(wksQ.Range("A65536") <> "", 65536, wksQ.Range("A65536").End(xlUp).Row)

ersatzlos gestrichen werden.

Ulf


Bild


Betrifft: AW: VBA - Suchen und aufaddieren von: günter
Geschrieben am: 05.02.2005 19:03:32

Hallo Josef,

schon wieder hast Du mir geholfen.

vielen Dank auch an Ulf.

Schönes Wochenende noch.-


gruss
günter


 Bild

Beiträge aus den Excel-Beispielen zum Thema "VBA - Suchen und aufaddieren"