Bestimmte Zeilen kopieren und löschen
02.07.2021 23:04:47
Sebastian
ich bin mal wieder am verzweifeln.......
Ich möchte aus der Mappe A aus mehreren Tabellenblättern Datenkopieren und dann bereinigen
Das funktioniert auch soweit.
Nun sollen aus anderen Tabellenblättern in der Mappe A nur Zeilen kopiert werden, bei denen in Spalte N die Zelle nicht leer ist (unabhängig vom Wert)
Code zum Kopieren und löschen des 1. Schrittes
Private Sub Abschluss_OK_Click()
Dim freieZeile As Long, freieZeile2 As Long, freieZeile3 As Long, letzteZeile As Long, wbZiel As Workbook
Application.ScreenUpdating = False
Set wbZiel = Workbooks.Open("C:\Users\Kaden\Documents\Dachser\Eingang CD FL Archiv.xlsm")
freieZeile = wbZiel.Worksheets("Steuerung").Cells(Rows.Count, 1).End(xlUp).Offset(1).Row
freieZeile2 = wbZiel.Worksheets("Produktionsanpassung").Cells(Rows.Count, 1).End(xlUp).Offset(1).Row
freieZeile3 = wbZiel.Worksheets("Prozessstörungen").Cells(Rows.Count, 1).End(xlUp).Offset(1).Row
With ThisWorkbook.Worksheets("Steuerung")
letzteZeile = .UsedRange.SpecialCells(xlCellTypeLastCell).Row
.Range("A4:T" & letzteZeile).Copy wbZiel.Worksheets("Steuerung").Cells(freieZeile, 1)
End With
With ThisWorkbook.Worksheets("Prozessstörungen")
letzteZeile = .UsedRange.SpecialCells(xlCellTypeLastCell).Row
.Range("A4:T" & letzteZeile).Copy wbZiel.Worksheets("Prozessstörungen").Cells(freieZeile3, 1)
End With
wbZiel.Close True
ThisWorkbook.Worksheets("Schleuse").Range("A3:AC1000").ClearContents
ThisWorkbook.Worksheets("Steuerung").Range("A4:AF1000").Interior.ColorIndex = 0
ThisWorkbook.Worksheets("Steuerung").Range("A4:AF1000").ClearContents
neuer_Tag2.Show
ThisWorkbook.SaveAs Filename:="C:\Users\Kaden\Documents\Dachser\Eingang CD FL V4.xlsm"
Me.Hide
Set wbZiel = Nothing
End Sub
Das sind meine beschaulichen Fortschritte......................... :(
Option Explicit
Public Sub kopieren_ProdAnPass()
Dim myRange As Range
Dim strAddress As String
Dim lngCounter As Long
Set myRange = Worksheets("Produktionsanpassung").Columns(14).Find(What:="kadens", After:=Worksheets("Produktionsanpassung").Cells(Rows.Count, 1), LookAt:=xlWhole)
Set wbZiel = Workbooks.Open("C:\Users\Kaden\Documents\Dachser\Eingang CD FL Archiv.xlsm")
If Not myRange Is Nothing Then
strAddress = myRange.Address
Do
lngCounter = lngCounter + 1
With wbZiel.Worksheets("Produktionsanpassung")
.Range(.Cells(.Cells(Rows.Count, 4).End(xlUp).Row + 1, 1), .Cells(.Cells(Rows.Count, 4).End(xlUp).Row + 1, 256)) = Worksheets("Produktionsanpassung").Range(Worksheets("Produktionsanpassung").Cells(myRange.Row, 1), Worksheets("Produktionsanpassung").Cells(myRange.Row, 256)).Value
End With
Set myRange = Worksheets("Produktionsanpassung").Columns(1).FindNext(myRange)
Loop While Not myRange Is Nothing And myRange.Address strAddress
End If
End Sub
Danke
Anzeige
