Tabelle automatisieren

Hallo an die Experten
Ich brauche dringend Eure Hilfe!!
Wo soll ich anfangen; ich erstelle
aus unserem Verwaltungssystem monatlich
eine Datentabelle in Excel. In einem anderen
Excel-File habe ich Verweise auf die neu erstellte
Tabelle, sodass immer die aktuellen Daten drin sind.
Nun ist mein Problem so, die Tabelle, welche monatlich
erstellt wird, logischerweise immer neue Daten enthält,
sprich, mehr Zeilen enthält wie im Vormonat.
Die vom System erzeugte Tabelle setzt sich wie folgt zusammen:
Spalte A = FondID
Spalte B = LgNr
Spalte C = Verkaufsdatum
Spalte D = LgArt
Noch diverse Spalten mit Daten, sind aber in diesem Fall nicht relevant.
Die LgArt in Spalte D ist die Bezugspalte (es gibt vier verschiedene Typen:
-Wohnhäuser
-Geschäftshäuser ohne wesentlichen Wohnanteil
-Gemischte Liegenschaften
-Bauland (inkl. Abbruchobjekte) und angefangene Bauten
Hier die Datei zum besseren Verständnis:

Die Datei https://www.herber.de/bbs/user/11796.xls wurde aus Datenschutzgründen gelöscht

Vielen Dank für Eure Hilfe
Gruss Lisa

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo
auf die schnelle hab ichs mal so gemacht:
Workbook Name musst du noch anpassen


Sub Auflisten()
Dim Tabelle As Worksheet, Thema As Integer, Index As Long
Dim Suchbereich As Range, RubrikZeile As Long, Rubrik As String, Zeile As Long
Dim Ergebnis() As Long, Spalte As Long, EndZelle As Long
ReDim Ergebnis(0 To 0)
On Error Resume Next
Application.ScreenUpdating = False
Application.Cursor = xlWait
Set Tabelle = Workbooks("Mappe1").Worksheets("monatlicheSysTab")
Set Suchbereich = Tabelle.UsedRange
With ThisWorkbook.Worksheets("Verknüpfung")
For Thema = 1 To 3
EndZelle = .Cells(65536, 5).End(xlUp).Row
Select Case Thema
Case 1: Rubrik = "Geschäftshäuser ohne wesentlichen Wohnanteil"
Case 2: Rubrik = "Gemischte Liegenschaften"
Case 3: Rubrik = "Bauland (inkl. Abbruchobjekte) und angefangene Bauten"
End Select
For Index = 73 To EndZelle
If .Cells(Index, 5) = Rubrik Then
RubrikZeile = Index
Exit For
End If
Next
Call Suche(Suchbereich, Rubrik, Ergebnis)
If UBound(Ergebnis) > 0 Then
Zeile = 0
For Index = 1 To UBound(Ergebnis)
RubrikZeile = RubrikZeile + 1
Zeile = Zeile + 1
For Spalte = 1 To 6
.Cells(RubrikZeile, Spalte) = _
Workbooks("Mappe1").Worksheets("monatlicheSysTab").Cells(Ergebnis(Index), Spalte)
Next
If Zeile > 4 Then
.Cells(RubrikZeile + 1, 1).EntireRow.Insert
End If
Next
End If
Next
End With
Application.ScreenUpdating = True
Application.Cursor = xlDefault
End Sub

Wie du merken wirst dauert das ganze jetzt länger. Normalerweise würde ich die Daten von monatlicheSysTab zuerst in ein Array kopieren und dann von dem Array in Verknüpfung kopieren. Aber dafür hab ich jetzt keine Zeit...
Informiere dich mal über Arrays:
z.B.:
Dim Feld()
Redim Feld(0 to 0)
....
....
Redim Preserve Feld(0 to index)
Feld(index)= cells(index,1)
....
....
mfg tobias

Sub Auflisten() Dim Tabelle As Worksheet, Thema As Integer, Index As Long Dim Suchbereich As Range, RubrikZeile As Long, Rubrik As String, Zeile As Long Dim Ergebnis() As Long, Spalte As Long, EndZelle As Long ReDim Ergebnis(0 To 0) On Error Resume Next Application.ScreenUpdating = False Application.Cursor = xlWait 'Workbook Name muss angepasst werden Set Tabelle = Workbooks("Mappe1.xls").Worksheets("monatlicheSysTab") Set Suchbereich = Tabelle.UsedRange With ThisWorkbook.Worksheets("Verknüpfung") For Thema = 1 To 3 EndZelle = .Cells(65536, 5).End(xlUp).Row Select Case Thema Case 1: Rubrik = "Geschäftshäuser ohne wesentlichen Wohnanteil" Case 2: Rubrik = "Gemischte Liegenschaften" Case 3: Rubrik = "Bauland (inkl. Abbruchobjekte) und angefangene Bauten" End Select For Index = 73 To EndZelle If .Cells(Index, 5) = Rubrik Then RubrikZeile = Index Exit For End If Next Call Suche(Suchbereich, Rubrik, Ergebnis) If UBound(Ergebnis) > 0 Then Zeile = 0 For Index = 1 To UBound(Ergebnis) RubrikZeile = RubrikZeile + 1 Zeile = Zeile + 1 For Spalte = 1 To 6 .Cells(RubrikZeile, Spalte) = _ Workbooks("Mappe1.xls").Worksheets("monatlicheSysTab").Cells(Ergebnis(Index), Spalte) 'Workbook Name muss angepasst werden Next If Zeile > 4 Then .Cells(RubrikZeile + 1, 1).EntireRow.Insert End If Next End If Next End With Application.ScreenUpdating = True Application.Cursor = xlDefault End Sub

Beliebteste Forumthreads (12 Monate)

8 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread