AW: Zelleninhalte verschieben
16.03.2018 13:15:40
yummi
Hallo Sabi,
kopier mal alles in ein Modul und passe in der Sub deine Sheet Namen an.
Option Explicit
Function BestimmeLetzteZeile(ByVal wks As Worksheet, ByVal s As Integer) As Long
BestimmeLetzteZeile = wks.Cells(wks.Rows.Count, s).End(xlUp).Row
End Function
Function FindeWert(ByVal wks As Worksheet, ByVal strRange As String, ByVal strWert As String) _
As Range
Dim rng As Range
If strRange "" Then
Set rng = wks.Range(strRange).Find(strWert, LookAt:=xlWhole)
Else
Set rng = Nothing
End If
If rng Is Nothing Then
Set rng = wks.Range(strRange).Find(strWert, LookAt:=xlPart)
End If
Set FindeWert = rng
End Function
Function BestimmeLetzteSpalte(ByVal wks As Worksheet, ByVal z As Long) As Integer
If wks.Cells(z, 1).Value "" Then
BestimmeLetzteSpalte = wks.Cells(z, wks.Columns.Count).End(xlToLeft).Column
Else
BestimmeLetzteSpalte = 1
End If
End Function
Function Beschleunigen(ByVal BGesetzt As Boolean)
BGesetzt = Not BGesetzt
With Application
.ScreenUpdating = BGesetzt
.AskToUpdateLinks = BGesetzt
.EnableEvents = BGesetzt
.Calculation = BGesetzt
.DisplayAlerts = BGesetzt
End With
End Function
Function WandleZahlInBuchstaben(ByVal iWert As Integer) As String
Dim Spaltenbuchstabe As String
Spaltenbuchstabe = Right(Columns(iWert).Address, Len(Columns(iWert).Address) - InStrRev( _
Columns(iWert).Address, "$"))
WandleZahlInBuchstaben = Spaltenbuchstabe
End Function
Sub DatenVerschieben()
Dim lastS As Integer
Dim lastZS As Long
Dim lastZD As Long
Dim wksS As Worksheet
Dim wksD As Worksheet
Dim i As Integer
Dim rng As Range
Beschleunigen True
Set wksS = ThisWorkbook.Sheets("Tabelle2") 'Source
Set wksD = ThisWorkbook.Sheets("Tabelle1") 'Destination
lastS = BestimmeLetzteSpalte(wksD, 1) 'letzte Spalte in Zeile 1 auf Destination
lastZD = BestimmeLetzteZeile(wksD, 1) 'letzte Zeile in Spalte A auf Destination
lastZS = BestimmeLetzteZeile(wksS, 1) 'letzte Zeile in Spalte A auf Source
For i = 1 To lastS
Set rng = FindeWert(wksD, "A1:" & WandleZahlInBuchstaben(lastS) & 1, wksS.Cells(1, i).Value) _
If Not rng Is Nothing Then
wksS.Range(WandleZahlInBuchstaben(i) & 2 & ":" & WandleZahlInBuchstaben(i) & lastZS). _
Copy wksD.Range(WandleZahlInBuchstaben(rng.Column) & lastZD + 1)
wksS.Range(WandleZahlInBuchstaben(i) & 2 & ":" & WandleZahlInBuchstaben(i) & lastZS). _
Value = ""
Else
MsgBox "Spalte nicht gefunden"
End If
Set rng = Nothing
Next i
Beschleunigen False
End Sub
Gruß
yummi