AW: Zusatzfragen
26.05.2011 02:44:34
fcs
Hallo Thorsten,
leider ist der Zeilenauf in den beiden Blättern nicht identisch (In Blatt "TEST NEU" sind Leerzeilen zwischen einzelnen Positionen, im Blatt "TEST NEU 2011" nicht.
Dadurch ist es aufwendiger zu übertragen, da eine Prüfung eingebaut und zeilenweise übertragen werden muss.
Gruß
Franz
'##############################################################
'# Windows Vista - Excel 2007 - VBA 6.5.1053 #
'# fcs 2011-05-26 #
'# Modul: Allgemeines Modul #
'# Überträgt Spalteninhalte gemäß Suchkriterium in Zielspalte #
'# Makros sollten auch unter Excel 2003 lauffähig sein #
Sub DatenUebertragen()
'Variante, wenn im Zielblatt alle Positionen aus Spalte B der Quelle _
vorhanden sind, aber keine Leerzeilen zwischen den Positionen.
Dim wksZiel As Worksheet, wksQuelle As Worksheet
Dim sFind As String, rFind As Range, Spalte_Z As Long, Spalte_Q As Long
Dim Spalte_ZTQ As Long, Zeile_TQ As Long, Zeile_TZ As Long
Dim Zeile_Q As Long, Zeile_Z As Long
Set wksQuelle = Worksheets("TEST NEU") ' oder ActiveSheet
Set wksZiel = Worksheets("TEST IST 2011")
'Zeile mit Spaltentiteln in Quelle
Zeile_TQ = 3
'Spalte mit den zu übertragenden Werten
Spalte_Q = 20 'Spalte T
'Spalte mit den Zeilentiteln in Quelle
Spalte_ZTQ = 2 'Spalte B
'Zeile mit Spaltentiteln in Ziel
Zeile_TZ = 2
'zu suchender Begriff
sFind = wksQuelle.Range("T3")
'führende Null beim Monat ggf. entfernen
sFind = Replace(sFind, " 0", " ", 1)
With wksZiel
Set rFind = .Rows(Zeile_TZ).Find(What:=sFind, Lookat:=xlWhole, LookIn:=xlValues)
End With
If rFind Is Nothing Then
MsgBox "Monat """ & sFind & """ wurde in Zeile " & Zeile_TZ & " im Blatt " _
& wksZiel.Name & " nicht gefunden!"
Else
Spalte_Z = rFind.Column
'Altdaten in Zielspalte löschen
With wksZiel
If .Cells(.Rows.Count, Spalte_Z).End(xlUp).Row > Zeile_TZ + 1 Then
.Range(.Cells(Zeile_TZ + 2, Spalte_Z), _
.Cells(.Rows.Count, Spalte_Z).End(xlUp)).ClearContents
End If
End With
With wksQuelle
Zeile_Z = Zeile_TZ + 1
'In Quelle zeilenweise prüfen ob Inhalt in Spalte B vorhanden und _
ggf. Wert nach Ziel übertragen
For Zeile_Q = Zeile_TQ + 2 To .Cells(.Rows.Count, Spalte_ZTQ).End(xlUp).Row
If .Cells(Zeile_Q, Spalte_ZTQ) "" Then
Zeile_Z = Zeile_Z + 1
wksZiel.Cells(Zeile_Z, Spalte_Z).Value = .Cells(Zeile_Q, Spalte_Q).Value
End If
Next
End With
Application.CutCopyMode = False
End If
End Sub
Sub DatenUebertragen_Variante()
'Variante, wenn der Zeilenaufbau in beiden Blättern identisch ist
Dim wksZiel As Worksheet, wksQuelle As Worksheet
Dim sFind As String, rFind As Range, Spalte_Z As Long, Spalte_Q As Long
Dim Zeile_TQ As Long, Zeile_TZ As Long
Set wksQuelle = Worksheets("TEST NEU") ' oder ActiveSheet
Set wksZiel = Worksheets("TEST IST 2011")
'Zeile mit Spaltentiteln in Quelle
Zeile_TQ = 3
Spalte_Q = 20 'Spalte T
'Zeile mit Spaltentiteln in Ziel
Zeile_TZ = 2
sFind = wksQuelle.Range("T3")
'führende Null beim Monat ggf. entfernen
sFind = Replace(sFind, " 0", " ", 1)
With wksZiel
Set rFind = .Rows(Zeile_TZ).Find(What:=sFind, Lookat:=xlWhole, LookIn:=xlValues)
If rFind Is Nothing Then
MsgBox "Monat """ & sFind & """ wurde in Zeile " & Zeile_TZ & " im Blatt " _
& wksZiel.Name & " nicht gefunden!"
Else
Spalte_Z = rFind.Column
'Altdaten in Zielspalte löschen
If .Cells(.Rows.Count, Spalte_Z).End(xlUp).Row > Zeile_TZ + 1 Then
.Range(.Cells(Zeile_TZ + 2, Spalte_Z), _
.Cells(.Rows.Count, Spalte_Z).End(xlUp)).ClearContents
End If
With wksQuelle
'Quelldaten kopieren, falls Daten vorhanden sind
If .Cells(.Rows.Count, Spalte_Q).End(xlUp).Row > Zeile_TQ + 1 Then
.Range(.Cells(Zeile_TQ + 2, Spalte_Q), .Cells(.Rows.Count, Spalte_Q).End(xlUp)).Copy
wksZiel.Cells(Zeile_TZ + 2, Spalte_Z).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
End If
End With
End If
End With
End Sub