Live-Forum - Die aktuellen Beiträge
Datum
Titel
24.04.2024 19:29:30
24.04.2024 18:49:56
Anzeige
Archiv - Navigation
560to564
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
560to564
560to564
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Inhaltsverzeichnis

VBA - Suchen und aufaddieren

VBA - Suchen und aufaddieren
05.02.2005 18:07:53
Günter
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

3
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: VBA - Suchen und aufaddieren
05.02.2005 18:45:26
Josef
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 
P.S.: Rückmeldung nicht vergessen!
Anzeige
AW: VBA - Suchen und aufaddieren
Ulf
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
AW: VBA - Suchen und aufaddieren
05.02.2005 19:03:32
günter
Hallo Josef,
schon wieder hast Du mir geholfen.
vielen Dank auch an Ulf.
Schönes Wochenende noch.-
gruss
günter

308 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige