excel sheet spalten auslesen

[pfeffis 11]

Hallo Gemeinde!

 

Es gibt eine Tabelle mit Spalten A-G.

Beispiel:

 

A B C D E F G

a1 b1 farbe1 farbe2 farbe3 farbe4 g1

a2 b2 farbe1 farbe2 farbe3 farbe4 g2

.

.

 

Diese Tabelle soll nach Ausführung eines Makros so aussehen:

 

A B C D

a1 b2 farbe1 g1

a1 b2 farbe2 g1

a1 b2 farbe3 g1

a1 b2 farbe4 g1

a2 b2 farbe1 g2

.

.

.

 

Das ganze soll nach dem Schema in Tabelle2 kopiert werden.

dieses makro schnipsel habe ich als vorlage genommen, komme aber nicht so recht weiter :(

 

Sub CopyPrim()

Quelle = "Tabelle1"

Ziel = "Tabelle2"

Yziel = 1

 

With Sheets(Quelle)

'Durchlaufe alle Zeilen der Quelle

For Yquelle = 1 To .Cells.SpecialCells(xlCellTypeLastCell).Row

'Durchlaufe 23x alle Spalten der Quelle

For i = 1 To 23

For Xquelle = 1 To .Cells.SpecialCells(xlCellTypeLastCell).Column

'Zellinhalt kopieren

Sheets(Ziel).Cells(Yziel, Xquelle) = .Cells(Yquelle, Xquelle)

Next

Yziel = Yziel + 1

Next

Next

End With

End Sub

[d.stegemann 10]

Hallo pfeffis,

 

eine wichtige Frage vorab...

 

Unter welcher Office Version soll denn das Makro laufen?

 

 

Gruß

 

Dirk

[pfeffis 11]

ms office 2003 und/oder 2007

[d.stegemann 10]

Hallo pfeffis,

 

ich habe nur Office 2000 da...

 

aber ich denke der Code sollte auch bei dir laufen...

 

Sub Makro1()
'
' Makro1 Makro
' Makro am 16.03.2009 von Dirk aufgezeichnet
'

'
istart = 1 'Bereich x-Achse Anfang
iend = 7 ' Bereich x-Achse Ende
izeilenew = 1
istartnew = 0

sheets_num = ActiveWorkbook.Sheets.Count
Sheets(2).Select
'MsgBox sheets_num

izeilenzahl = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
'    MsgBox izeilenzahl

For izeile = 1 To izeilenzahl
'MsgBox izeile
 For ispalte = istart To iend
   Sheets(2).Select
   Range(Cells(izeile, istart), Cells(izeile, istart)).Select
  ' MsgBox istart, vbCritical, izeile
   Selection.Copy
   Sheets(1).Select
     Select Case istart
       Case iend
       'MsgBox izeilenew
       Range(Cells(izeilenew - istartnew, istartnew + 1), Cells(izeilenew, istartnew + 1)).Select
       ActiveSheet.Paste
       ihelper = izeilenew - istartnew + 1
         Do While ihelper <= izeilenew
           Cells(ihelper, 1).Value = Cells(izeilenew - istartnew, 1).Value
           ihelper = ihelper + 1
         Loop
       izeilenew = izeilenew + 1
       istart = istart + 1
    Case Else
      If istartnew > 2 Then
        izeilenew = izeilenew + 1
      Else
        istartnew = istartnew + 1
      End If
      Range(Cells(izeilenew, istartnew), Cells(izeilenew, istartnew)).Select
      ActiveSheet.Paste
      istart = istart + 1
      ' MsgBox istartnew, vbCritical, izeilenew
    End Select
  Next
istart = 1
istartnew = 0
Next
 Sheets(2).Select
 Range(Cells(izeilenzahl, istart + 1), Cells(izeilenzahl, istart + 1)).Select
 Selection.Copy
 Sheets(1).Select
 Range(Cells(1, 2), Cells(izeilenew - 1, 2)).Select
 ActiveSheet.Paste
 Range(Cells(1, 1), Cells(1, 1)).Select
End Sub


[/Code]

 

Ich habe halt von Tabelle2 auf Tabelle1 kopiert. Das sollte aber kein Problem sein...

 

Gruß

 

Dirk

[pfeffis 11]

WoW. vielen Dank. Kleines Problemchen noch:

Die Werte sehen statt so

 

A B C D

a1 b2 farbe1 g1

a1 b2 farbe2 g1

a1 b2 farbe3 g1

a1 b2 farbe4 g1

 

so

 

A   B    C       D
a1 b2 farbe1
       farbe2
       farbe3 
       farbe4 

aus.

 

Sprich spalte g wird gar nicht übernommen und die werte werden nur einmalig beim Sprung in die nächste zeile übernommen. bei spalte b steht nun auch immer eine 1 als wert drinnen.

 

Stand vorm umwandeln:

 

A   B      C       D       E        F     G
a1 b1 farbe1 farbe2 farbe3 farbe4 g1
a2 b2 farbe1 farbe2 farbe3 farbe4 g2

 

Stand nach dem umwandeln:

 

A       B      C        D
a1     1    farbe1   
       1    farbe2
       1    farbe3 
       1    farbe4
a2     1    farbe1
       1    farbe2
... 

[d.stegemann 10]

Ich hänge mal meine Datei mit ran...

 

Die Befüllung der Spalten a und g erfolgt beim letzten Durchlauf pro Zeile(iend) der Quelltabelle.

 

Spalte b wird nach durchlauf der Schleifen auf Basis der letzten Zeile der Quelltabelle gefüllt.

Vielleicht sieht dein Blatt doch ein wenig anders aus :)

 

Vielleicht interpretiert dein Office den Code auch ein wenig anders.

 

Hilfreich könnten auch die msgboxen im Code sein. Nimm einfach die Kommentare raus, dann siehst du ja was passiert.

 

Gruß

 

Dirk

Neu Microsoft Excel-Arbeitsblatt.zip

[Cybquest 36]

Hier noch ne Möglichkeit, angelehnt an Deinen Beispielcode:

 

Sub CopyPrim()
Dim varSpalte1 As Object
Quelle = "Tabelle1"
Ziel = "Tabelle2"
YZiel = 1

With Sheets(Quelle)
'Durchlaufe alle Zeilen der Quelle
 For YQuelle = 1 To .Cells.SpecialCells(xlCellTypeLastCell).Row
'Durchlaufe 3. bis vorletzte Spalte der Quelle
   For XQuelle = 3 To .Cells.SpecialCells(xlCellTypeLastCell).Column - 1
'Zellinhalt umkopieren
     Sheets(Ziel).Cells(YZiel, 1) = .Cells(YQuelle, 1)
     Sheets(Ziel).Cells(YZiel, 2) = .Cells(YQuelle, 2)
     Sheets(Ziel).Cells(YZiel, 3) = .Cells(YQuelle, XQuelle)
     Sheets(Ziel).Cells(YZiel, 4) = .Cells(YQuelle, .Cells.SpecialCells(xlCellTypeLastCell).Column)
     YZiel = YZiel + 1
   Next
 Next
End With

End Sub

[pfeffis 11]

Danke euch beiden.

Gibt es jetzt noch die Möglichkeit, wenn bspw. nur farbe1 und farbe2 in einer zeile stehen und farbe3, 4 etc. nicht befüllt sind gleich auf die nächste zeile zu springen?

 

Tausend Dank nochmal

[Cybquest 36]

Like this?

Sub CopyPrim()
Dim varSpalte1 As Object
Quelle = "Tabelle1"
Ziel = "Tabelle2"
YZiel = 1

With Sheets(Quelle)
'Durchlaufe alle Zeilen der Quelle
 For YQuelle = 1 To .Cells.SpecialCells(xlCellTypeLastCell).Row
'Durchlaufe 3. bis vorletzte Spalte der Quelle
   For XQuelle = 3 To .Cells.SpecialCells(xlCellTypeLastCell).Column - 1
'Zellinhalt umkopieren
     If .Cells(YQuelle, XQuelle) <> "" Then
     Sheets(Ziel).Cells(YZiel, 1) = .Cells(YQuelle, 1)
     Sheets(Ziel).Cells(YZiel, 2) = .Cells(YQuelle, 2)
     Sheets(Ziel).Cells(YZiel, 3) = .Cells(YQuelle, XQuelle)
     Sheets(Ziel).Cells(YZiel, 4) = .Cells(YQuelle, .Cells.SpecialCells(xlCellTypeLastCell).Column)
     YZiel = YZiel + 1
     End If
   Next
 Next
End With

End Sub

[pfeffis 11]

@cyberquest: Du bist ja mal geil :D

Vielen Dank nochmal an euch beide! Klappt super und spart mir mindestens einen Tag arbeit :cool:

[Cybquest 36]

Danke :)

 

Ist immer wieder schön, wenn man mit ein paar Zeilen Code jemanden glücklich machen kann ;)