PDA

Vollständige Version anzeigen : Makro Daten verschieben wenn Zellen ungleich


Schneckbert
23.09.2011, 11:13
Guten Morgen liebes Forum!
Ich brauche Hilfe..

In meiner neuen Abteilung habe ich eine Aufgabe bekommen die mich zum verzweifeln bringt (aufgrund fehlender VBA Kenntnisse)Ich nutze Excel 2003!

Der Fall:

Ich habe eine Tabelle die wie folgt aussieht
http://img4.fotos-hochladen.net/uploads/bspm3y12cao9u.jpg


wie ihr seht habe ich A8 und F8 gekennzeichnet - denn dort ist das Problem!
Wenn A8 und F8 (z.B) nicht identisch sind soll A8-D8 nach unten verschoben werden und F8-I8 soll stehen bleiben - damit die Daten nicht falsch werden.. (Denn wenn bei A8 eine andere Nr als F8 steht sind es 2 verschiedene Kraftwerke und somit sind es verschiedene - dann falsche - Daten!

Also zusammengefasst:
Wenn A8 nicht identisch mit F8 dann Bereich A8-D8 (und alles was dadrunter ist!!!!) nach unten verschieben.. sodass immer A und F identisch sind..

Problemfall:

Wenn es so aussieht:
http://img4.fotos-hochladen.net/uploads/prob17u54yfqvke.jpg
dann muss alles unter A5-D5 nach unten verschoben werden
und F5-I5 + alles was darunter ist nach unten..
sodas es danach so aussieht:
http://www.fotos-hochladen.net/uploads/prob24kdfe0lqsw.jpg

Ja das ist also mein Problem und ich hoffe mir kann jemand helfen denn die nächste Arbeit wartet schon auf mich :/ und das auf nem Freitag! (:

wenn ich irgendwas komisch erklärt habe, einfach nachfragen!

danke für eure Hilfe!!

CitizenX
24.09.2011, 02:50
Hi,

probier mal ob's so passt:

( Code ins Modul der Tabelle-> Rechtsklick auf den Reiter->Code anzeigen->Code einfügen )

Option Explicit

Sub verschieben()
Dim Zelle As Range, i As Long
Dim Arr1 As Range, Arr2 As Range, myContainer As Range


Set Arr1 = Range("A3:A" & Cells(Cells.Rows.Count, 1).End(xlUp).Row)
Set Arr2 = Range("F3:F" & Cells(Cells.Rows.Count, 6).End(xlUp).Row)

For Each Zelle In Arr1
i = i + 1
If Len(Trim(Zelle)) > 0 And Len(Trim(Arr2(i, 1))) > 0 And Zelle <> Arr2(i, 1) Then
If myContainer Is Nothing Then
Set myContainer = Union(Arr1(i + 1).Resize(1, 4), Arr2(i).Resize(1, 4))
Else
Set myContainer = Union(myContainer, Arr1(i + 1).Resize(1, 4), Arr2(i).Resize(1, 4))
End If
End If
Next

If Not myContainer Is Nothing Then myContainer.Insert Shift:=xlDown

End Sub