title image


Smiley (E97)VBA-Problem: Daten von vertikal in horizontal
Hallo Leute,



Hatte hier vor kurzen eine gute Unterstützung erhalten von QuentinT.

Wollte Datensätze, die untereinander stehen, ins richtige TABELLENFORMAT (horizontal) in zweite Tabelle übertragen.

Das Makro läuft recht gut, es hat nur einen Schönheitsfehler. Alle Daten werden direkt untereinander geschrieben (End(xlUp)) und nicht in die Zeile, wo sie hingehören. End(xlUp) scheint nicht der richtige Weg zu sein. Case 1 bedeutet IMMER NEUE ZEILE (neuer Datensatz).

Denn es kommt vor, dass diese oder jenige P-Nr. in Spalte 1, Tabelle mal fehlt.

Die Daten aus Spalte 3 Tabelle 1 sollen nur übertragen werden, wenn die definerte P-Nr. (Case 1-6) vorhanden ist.

Kann mir jemand helfen, ich konnte echt professionelle Hilfe ganz dringend gebrauchen!!!!

QuentinT wollte nicht so richtig an die Endlösung ran.

Das Problen liegt wohl an der Zieladdresse (End(xlUp)).

Die Nr. P100000 bedeutet immer - neuer Datensatz - und ist auch immer vorhanden! Die anderen Daten sollen jeweils, wenn vorhanden eine Spalte weitereingetragen werden.

Ach ja, die Datensätze beginnen in Zeile 2 (Spaltenköpfe).

Kann mir bitte jemand helfend unter die Arme greifen????



Gruß Hardy (Ratlos)



Hier das Makro:

Option Explicit

Sub übertragen()

Dim SB As String, C As Range, A As Byte

Dim WS1 As Worksheet, WS2 As Worksheet

Dim FAdd As String



Set WS1 = Sheets(1)

Set WS2 = Sheets(2)



If WS2.[a2] "" Then Exit Sub



For A = 1 To 6

Select Case A

Case 1: SB = "P10000" 'Neue Zeile, neuer Datensatz Spalte1

Case 2: SB = "P20000" 'Spalte2

Case 3: SB = "P30000" 'Spalte3

Case 4: SB = "P40000" 'Spalte4

Case 5: SB = "P41000" 'Spalte5

Case 6: SB = "P42000" 'Spalte6

End Select

With WS1.Columns(1)

Set C = .Find(SB, LookIn:=xlValues, Lookat:=xlWhole, SearchOrder:=xlByRows)

If Not C Is Nothing Then

FAdd = C.Address

Do

On Error GoTo ENDE

WS2.Cells(65536, A).End(xlUp).Offset(1, 0) = C.Offset(0, 3) '????

Set C = .FindNext(C)

Loop While Not C Is Nothing And C.Address FAdd

End If

End With

Next

ENDE:

Set WS1 = Nothing

Set WS2 = Nothing

End Sub







geschrieben von

Login

E-Mail:
  

Passwort:
  

Beitrag anfügen

Symbol:
 
 
 
 
 
 
 
 
 
 
 
 
 

Überschrift: