Spalten mit gleichen Überschriften untereinander

[snb]

Wie du sehen kannst ignoriere ich Zeile 1.

Alle Daten ab A3 werden miteinbezogen, es gibt keine Beschränkung, so lange es keine leere Spalten oder leere Zeilen gibt zwischen den Daten.
Vorausgesetzt wid nur das jeder Gruppe 18 Zellen umfasst: Name, Code und 2001 bis 2016.
Vorausgesetzt wird auch dass die Spalte Identifikation zwischen (..) im 'Code' stehen.
Mehr gibt's nicht.

[Funkydonkey]

Erstmal nochmal danke für jede Mühe!
Zu später Stunde ist mir jetzt noch etwas aufgefallen. Ist es möglich, dass Name und Code jeweils für sich (natürlich wie gehabt im Verbund im 18er Block) eines Unternehmens immer auch in der gleichen Zeile stehen? Beispielsweise der Block H21 bis H38 und I21 bis I38. Hier wäre jetzt D:TIN neben D:SFQ-->nicht so gut;) 
Ist es möglich, dass jedes Unternehmen in jeder Zeile "für sich" steht? Also beispielsweise Zeile 22 nur D:TIN, und in Zeile 40 nur D:SFQ.

Danke!
Zur Verdeutlichung lade ich noch ein Bild hoch: 
Dateiupload bitte im Forum! So geht es: Klick mich!


PS: Mir fällt jetzt noch ein, man sortiert ja quasi die Blöcke zuerst nach Spalten (links/rechts), in einem zweiten Schritt bzw. zweiten Makro könnten in der gleichen Form die Blöcke dann nach Zeilen (oben/unten) sortiert werden, oder? Ist nur so eine Idee.

[snb]

Wenn du etwas hochladen willst: bitte tue das hier ins Forum. Dann bleibt dies ein sinnvolle thread auch für spätere Besucher.

[snb]

Was du fragst ist alles möglich.
Aber.... dieses Forum is zum helfen das selbt zu erstellen.
Ich fürchte das es in deiner Fall mehr ein 'Auftrag' sein würde als eine 'Hilfe'.
Uberlege ob es dann nicht besser wäre das als Auftrag zu sehen und jemand damit zu beschäftige den du dafür bezahlen könntest. (Es ist doch auch keine private Frage, meine ich).

[Fennek]

Hallo,

Bis jetzt habe ich diesen Beitrag mitgelesen, und muss zugeben, dass der vba-Vorschlag meine Kenntnisse deutlich übersteigt. Interessant...

Aber bei der Struktur von Daten3.xls frage ich mich, ob es nicht einfacher wäre, eine Hilfszeile z.b. mit 1, 2, 3 usw so anzulegen, dass die Kurse dieselbe Zahl wie die Umsätze haben und dann ganz einfach mit den Funktionen des Menüs nach Spalten zu sortieren.
Dann stehen für eine Firma Aktienkurse und Umsätze direkt nebeneinander und könne danach weiter verarbeitet werden.

(Sorry, für solche effizienz bzw einfach-ist-besser posts)

[Funkydonkey]

Was du fragst ist alles möglich.
Aber.... dieses Forum is zum helfen das selbt zu erstellen.
Ich fürchte das es in deiner Fall mehr ein 'Auftrag' sein würde als eine 'Hilfe'.
Uberlege ob es dann nicht besser wäre das als Auftrag zu sehen und jemand damit zu beschäftige den du dafür bezahlen könntest. (Es ist doch auch keine private Frage, meine ich).

Es geht in diesem Fall um eine Auswertung für meinen Professor.. Und wenn es dann so geordnet ist wie beschrieben, könnte ich endlich damit weiter arbeiten-->Access-->SPSS-->Modell.
Ich ändere das Bild nachher, dass es hier im Forum bleibt!

[Funkydonkey]

Hier nochmal das Bild im Anhang:

[atilla]

Hallo Funkydonkey,

teste mal folgenden Code in einer Kopie Deiner Datei:

Code:

Option Explicit

Sub umverteilen()

Dim i As Long, j As Long
Dim lngZ As Long
Dim lngS As Long
Dim lngBlock As Long
Dim lngA As Long


lngZ = Cells(Rows.Count, 1).End(xlUp).Row
lngS = Cells(1, Columns.Count).End(xlToLeft).Column
lngBlock = 2016 - 2001 + 3

Application.ScreenUpdating = False
On Error Resume Next
For i = 4 To lngZ Step lngBlock
  For j = 2 To lngS
    If Cells(i, j) <> "" And Not IsError(Cells(1, j)) Then
      If Replace(Split(Cells(i, j), "(")(1), ")", "") <> Cells(1, j) Then
        lngA = Application.WorksheetFunction.Match(Replace(Split(Cells(i, j), "(")(1), ")", ""), Rows(1), 0)
        With Range(Cells(i - 1, j), Cells(i + lngBlock - 2, j))
          .Copy Range(Cells(i - 1, lngA), Cells(i + lngBlock - 2, lngA))
          .Value = "#NA"
          .Interior.ColorIndex = 6    'Farbsetzung; diese Zeile kann bei nicht gebrauch gelöscht werden
          Range(Cells(i - 1, lngA), Cells(i + lngBlock - 2, lngA)).Interior.ColorIndex = 6 'Farbsetzung; diese Zeile kann bei nicht gebrauch gelöscht werden
        End With
      End If
    End If
  Next j
Next i
Application.ScreenUpdating = True

End Sub

Ich färbe die Blöcke, die verschoben werden gelb, damit Du besser vergleichen kannst.
Die Zeilen, die die Blöcke färben sind im Code durch Kommentare kenntlich.

Da nicht alle Blöcke eingelesen werden und keine neue Tabelle eingefügt wird, ist der Code trotz Farbsetzung schneller als die Variante von snb.

Beachte, dass ich auch bei falscher Begung auch in die Überschriftzeile ein "#NA" reinschreibe.
Wenn da etwas anderes stehen soll, dann melde Dich.

[Funkydonkey]

Genial!:) Vielen Dank für deine tolle Lösung. In den letzten Stunden habe ich mich mit VBA beschäftigt und habe immerhin schon die ersten paar Zeilen von SNBs Code verstanden.  :21: 
Ich hoffe, jetzt kann ich die Daten "weiterverarbeiten" und muss mich erstmal nicht mehr an euch wenden:)
PS: Wie viele Monate/Jahre muss man sich mit VBA beschäftigen, um so was zu vollbringen?

[atilla]

Hallo Funkydonky,

folgende Zeile im Code muss gelöscht werden:

Code:

On Error Resume Next

Ich hatte diese beim Testen genutzt, da es durch Fehlferte in der Zeile 1 zu Fehlern kam und ich aber erst mal sehen wollte,
ob sonst der Code richtig arbeitet.

Unten stelle ich einen leicht erweiterten Code ein. Da werden eventuelle Fehler abgefangen.
Blöcke, die vom Code aus irgendeinem Grund nicht verarbeitet werden können, werden rot markiert.
Soweit ich gesehen habe wurde aber in der zuletzt eingestellten Datei alles verarbeitet

Code:

Option Explicit

Sub ordnen()

Dim i As Long, j As Long
Dim lngZ As Long
Dim lngS As Long
Dim lngBlock As Long
Dim lngA


lngZ = Cells(Rows.Count, 1).End(xlUp).Row
lngS = Cells(1, Columns.Count).End(xlToLeft).Column
lngBlock = 2016 - 2001 + 3

Application.ScreenUpdating = False
For i = 4 To lngZ Step lngBlock
 For j = 2 To lngS
   If Cells(i, j) <> "" And Not IsError(Cells(1, j)) Then
     If Replace(Split(Cells(i, j), "(")(1), ")", "") <> Cells(1, j) Then
       lngA = Application.Match(Replace(Split(Cells(i, j), "(")(1), ")", ""), Rows(1), 0)
       With Range(Cells(i - 1, j), Cells(i + lngBlock - 2, j))
         If IsNumeric(lngA) Then
           .Copy Range(Cells(i - 1, lngA), Cells(i + lngBlock - 2, lngA))
           .Value = "#NA"
           .Interior.ColorIndex = 6    'Farbsetzung; diese Zeile kann bei nicht gebrauch gelöscht werden
           Range(Cells(i - 1, lngA), Cells(i + lngBlock - 2, lngA)).Interior.ColorIndex = 6 'Farbsetzung; diese Zeile kann bei nicht gebrauch gelöscht werden
         Else
           .Interior.ColorIndex = 3  'Blöcke die nicht verarbeitet werden können werden rot markiert
         End If
       End With
     End If
   End If
 Next j
Next i
Application.ScreenUpdating = True

End Sub