Daten einlesen - Code anpassen
14.10.2004 11:17:37
Lisa
Ich hab vor einigen Tagen folgenden Code bekommen, um automatisch
Daten aus einer anderen Tabelle in eine Vorlage einzulesen.
Soweit so gut. Nun bräuchte ich einige Änderungen in Code und
komm allein nicht weiter.
Folgendes; In der Tabelle "Bestandestabelle" sind in folgenden Spalten
Formeln hinterlegt Spalte S, AA, AB, AN, diese Formeln dürfen aber
nicht überschriben werden von den eingelesenen Daten aus Sheet4.
Das Problem ist, dass die Spalten mittendrin sind und das im Sheet4
in diesen Spalten Werte stehen, also deshalb natürlich auch eingelesen
werden. Wie muss ich den Code anpassen, damit er mir beim einlesen die
oben erwähnten Spalten auslässt?
Noch was kleines - es sollte jedesmal, wenn ich den Code ausführe, die
alten Daten in der Tabelle "Bestandestabelle" löschen, bevor er die neuen
einliesst. Weil jetzt ist es so, dass er die neuen Daten unten anhängt und
dann sind die meissten doppelt drin. Es sind nämlich immer die selben Datensätze,ausser das die Werte ändern und ab und zu ein neuer hinzukommt.
Option Explicit
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 = Sheet4
Set Suchbereich = Tabelle.UsedRange
For Thema = 1 To 4
EndZelle = Worksheets("Bestandestabelle").Cells(65536, 5).End(xlUp).Row
Select Case Thema
Case 1: Rubrik = "Wohnhäuser"
Case 2: Rubrik = "Geschäftshäuser ohne wesentlichen Wohnanteil"
Case 3: Rubrik = "Gemischte Liegenschaften"
Case 4: Rubrik = "Bauland (inkl. Abbruchobjekte) und angefangene Bauten"
End Select
For Index = 7 To EndZelle
If Worksheets("Bestandestabelle").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 136
Worksheets("Bestandestabelle").Cells(RubrikZeile, Spalte) = _
Sheet4.Cells(Ergebnis(Index), Spalte)
Next
If Zeile > 7 Then
Worksheets("Bestandestabelle").Cells(RubrikZeile + 1, 1).EntireRow.Insert
End If
Next
End If
Next
Application.ScreenUpdating = True
Application.Cursor = xlDefault
End Sub
Private Sub Suche(Bereich As Range, Suchtext As String, Suchfeld() As Long)
Dim Adresse As String, Zähler As Long, Zelle As Range
On Error Resume Next
With Bereich
Set Zelle = .Find(Suchtext)
If Not Zelle Is Nothing Then
Adresse = Zelle.Address
Do
Zähler = Zähler + 1
ReDim Preserve Suchfeld(0 To Zähler)
Suchfeld(Zähler) = Zelle.Row
Set Zelle = .FindNext(Zelle)
Loop Until Not Zelle Is Nothing And Zelle.Address = Adresse
End If
End With
End Sub
Ich weiss, es ist viel auf einmal, aber ich komm echt micht weiter.
Wär schön, wenn jemand helfen könnte.
Danke schon mal und liebe Grüsse
Lisa