Rechnet ein PC nicht immer gleich??? Wo liegt der Fehler?

[Windsurfer76]

Hallo zusammen,

ich habe ein merkwürdiges Problem. In Vorebereitung auf eine Pivotauswertung von Rohdaten habe ich ein kleines Makro zusammengebaut.

Die Rohtabellen haben folgende Struktur:

Gebiet1
leer |Datum |Produkt
leer |Datum |Produkt
leer |Datum |Produkt
leer |Datum |Produkt
Gebiet2
leer |Datum |Produkt
leer |Datum |Produkt
leer |Datum |Produkt
leer |Datum |Produkt
Gebiet3
leer Datum Produkt
leer Datum Produkt
leer Datum Produkt
leer Datum Produkt
leer Datum Produkt
leer Datum Produkt
.... etc

d.h. in Spalte 1 habe ich immer die "Ankündigung" eines neuen Gebietes und eine Zeile drunter geht es dann mit den Einträgen von verschiedenen Daten und Produkten los.

Ziel des kleinen Makros ist nun die Spalte1 immer komplett mit dem Gebiet zu füllen um die ganze Sache dann bequem per Pivot auszuwerten.


Nach dem Makro soll das ganze dann so aussehen:

Gebiet1
Gebiet1 Datum Produkt
Gebiet1 Datum Produkt
Gebiet1 Datum Produkt
Gebiet1 Datum Produkt
Gebiet2
Gebiet2 Datum Produkt
Gebiet2 Datum Produkt
Gebiet2 Datum Produkt
Gebiet2 Datum Produkt
Gebiet3
Gebiet3 Datum Produkt
Gebiet3 Datum Produkt
Gebiet3 Datum Produkt
Gebiet3 Datum Produkt
Gebiet3 Datum Produkt
Gebiet3 Datum Produkt
... etc




Hierzu habe ich folgenden Code zusammengebastelt:

Dim Start1 As Integer
Dim End1 As Integer
Dim Startx As Integer
Dim Endx As Integer
Dim Tabellenende As Long


Range("A1").Value = "Gebiet"
Range("B1").Value = "Datum"
Range("C1").Value = "Produkt"


Tabellenende = Range("B65000").End(xlUp).Row    'Tabellenende auslesen
Endx = 1                                        'Endblockmarkierung zurücksetzen




    Start1 = Range("A1").End(xlDown).Row        'erster Startpunkt
    Range("A" & Start1).Select
    Selection.Copy
    
    End1 = Range("a" & Start1).End(xlDown).Row - 1 'erster Endpunkt
    
    Range("A" & Start1, "A" & End1).Select
    ActiveSheet.Paste
    
    
    
    Startx = Range("A" & End1).End(xlDown).Row 'zweiter Startpunkt
    Range("A" & Startx).Select
    Selection.Copy
        
    Endx = Range("A" & Startx).End(xlDown).Row - 1 'zweiter Endpunkt
    
    Range("A" & Startx, "A" & Endx).Select
    ActiveSheet.Paste
    
While Endx < Tabellenende

Startx = Range("B" & Endx).End(xlDown).Row
Range("A" & Startx - 1).Select
Selection.Copy
    
Endx = Range("B" & Startx).End(xlDown).Row

If Range("B" & Startx - 2).Value = "" Then
MsgBox "Fehler. Sie haben beim zusammenführen der Daten eine Leerzeile gelassen. Die Auswertung ist nicht mehr valide und wird abgebrochen", vbCritical
Exit Sub
End If

Range("A" & Startx, "A" & Endx).Select
ActiveSheet.Paste


Wend

Auch wenn man es wahrscheinlich viel eleganter löschen kann, funktioniert es - MANCHMAL!!!!!

Bei ein und dem selben Datensatz läuft der Code einmal richtig und einmal falsch. An der Stelle

Startx = Range("A" & End1).End(xlDown).Row 'zweiter Startpunkt
    Range("A" & Startx).Select
    Selection.Copy

nimmt er mir machmal das neue Gebiet (was er auch soll) und machmal das alte Gebiet, sprich entweder er geht nicht bis in die letzter beschriebene Zelle oder er hat beim vorherigen einfügen diese Zelle überschrieben.

Ich bin mir nicht sicher ob dies nachvollziehbar ist. Merkwürdig ist jedoch, dass es einmal funktioniert und einmal nicht. Macht das irgendeinen Sinn?

Vielleicht könnt ihr mir weiterhelfen. Entweder ich habe einen ganz dummen "Bock geschossen" oder der Rechner meiner Kollegin kann nicht 1 und 1 zusammenrechnen....

Viele Grüße vom Bodensee

[Severus]

Versuch mal

Sub aufbereiten()
Dim lngStartZeile As Long
Dim lngEndZeile As Long
Dim lngAktZeile As Long
With ActiveSheet
    lngStartZeile = .Cells(1, 1).End(xlDown).Row
    lngEndZeile = .Cells(.Cells.Rows.Count, 2).End(xlUp).Row
    For lngAktZeile = lngStartZeile To lngEndZeile
         If .Cells(lngAktZeile, 2) = "" Then
             MsgBox "Fehler. Sie haben beim Zusammenführen der Daten eine Leerzeile gelassen." _
             & Chr(10) & "Die Auswertung ist nicht mehr valide und wird abgebrochen.", vbCritical, "Fehler..."
             Exit Sub
         End If
        If .Cells(lngAktZeile, 1) = "" Then
            .Cells(lngAktZeile, 1) = .Cells(lngAktZeile - 1, 1)
        End If
    Next lngAktZeile
End With
End Sub

Severus