AW: kopieren bereich ohne leerzeilen
28.06.2006 21:47:32
karel
Hallo Beate
das hauptproblem ist das datenbereich geht von a2:aa2500 die Daten sind alle uber sverweis drin.
vorlage Tabelle deutsch, englisch etc hat überscriften und unterschriften
Habe selbst schon viel probiert aber sitze Total auf false spur
sehe code
Sub Bereich_übertragen()
Application.ScreenUpdating = False
Dim ws1 As Worksheet, ws2 As Worksheet
Dim i As Integer
Set ws1 = ThisWorkbook.Worksheets("start")
Set ws2 = ThisWorkbook.Worksheets("deutsch")
ws2.Activate
' Löschen Spalte A_S
Range("A29:AC2500").Select
ActiveWindow.ScrollRow = 4
Selection.ClearContents
Range("a24").Select
'zeilen einblenden
For i = 2525 To 28 Step -1
If Cells(i, 1).Value = "" Then Cells(i, 1).EntireRow.Hidden = False
Next
' Kopieren
Select Case Worksheets("eingabe").Range("C4").Value
Case 1: Set ws2 = ThisWorkbook.Worksheets("deutsch")
Case 2: Set ws2 = ThisWorkbook.Worksheets("englisch")
Case 3: Set ws2 = ThisWorkbook.Worksheets("französisch")
Case Else: Set ws2 = ThisWorkbook.Worksheets("deutsch")
End Select
ws1.Range("A3:AA2500").Copy
ws2.Cells(ws2.Cells(Rows.Count, 30).End(xlUp).Row + 28, 1). _
PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
'Länder ohne duplikaten Sortieren
ws2.Activate
Range("B29:AA2500").Select
Selection.Sort Key1:=Range("Z28"), Order1:=xlAscending, _
Header:=xlGuess, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom
Dim Blatt As Worksheet
Dim Zelle As String
Set Blatt = ActiveSheet
On Error Resume Next
Zelle = Range("AA28:AA2500", Range("AA28:AA2500").End(xlDown)).Address
Range(Zelle).AdvancedFilter Action:=xlFilterCopy, _
CopyToRange:=Range("AB29"), Unique:=True
Zelle = Range("Z28:Z2500", Range("Z28:Z2500").End(xlDown)).Address
Range(Zelle).AdvancedFilter Action:=xlFilterCopy, _
CopyToRange:=Range("AC29"), Unique:=True
'zeilen ausblenden
Application.ScreenUpdating = False
For i = 2525 To 28 Step -1
If Cells(i, 1).Value = "" Then Cells(i, 1).EntireRow.Hidden = True
Next
Range("a24").Select
End Sub
Karel