Excel VBA Werte kopieren in Bereich

Hallo Excel Experten ;-)
Ich komme wieder mal nicht weiter mit einem Excel-Makro.
Ich möchte mit VBA, Werte aus einer Spalte in einen vorgegebenen Bereich mit mehreren Spalten und Zeilen kopieren.
Ich habe in Sheet(PLOs COOIS) in Spalte ("C" & 2, "C" & 18) 17-Artikelnr. welche ich in Sheet(TTP) in den Bereich ("A" & 4, "E" & 11) kopieren möchte. Der Bereich kann jedoch nicht vergrössert werden. Die Anzahl zu kopierenden Artikelnr. sind immer unterschiedlich, aber nie mehr als die Anzahl Zellen in den zu kopierenden/vorgegebenen Bereich.
Die gesamte Excel-Datei wird zur Produktionsplanung genutzt und bis jetzt habe ich diesen Vorgang immer manuell durchgeführt und dies bei 21 Dateien. Bei einigen Dateien sind dies sogar mehr als über 100 Artikelnr. welche ich manuell kopieren muss.
Daher würde mir ein Makro einiges an Zeit ersparen.
Hat jemand eine Idee/Lösung für mein Problem?
Hier meine Datei: https://www.herber.de/bbs/user/141257.xlsm
Ich danke schon im Voraus für jede Hilfe!
Gruss Romeo

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub PLO_to_TTP() Dim arPLO, i As Integer, x arPLO = Worksheets("PLOs COOIS").Range("C2:C18") With ThisWorkbook.Worksheets("TTP") i = 1 For Each x In .Range("A4:E11") If i > UBound(arPLO) Then Exit For x.Value = arPLO(i, 1) i = i + 1 Next End With Erase arPLO End Sub


Sub PLOs_to_KiraD()
Dim arPLO, i As Integer, x As Range, rBereich As Range
Worksheets("PLOs COOIS").Unprotect ("xxx")
With Worksheets("PLOs COOIS")
Set rBereich = .Range("C2:C" & .Cells(Rows.Count, "C").End(xlUp).Row)
ReDim arPLO(1 To rBereich.SpecialCells(xlCellTypeVisible).Count)
For i = 1 To rBereich.SpecialCells(xlCellTypeVisible).Count
arPLO(i) = rBereich.SpecialCells(xlCellTypeVisible).Cells(i).Value
Next
End With
With ThisWorkbook.Worksheets("TTP")
i = 1
For Each x In .Range("A13:E17")
If i > UBound(arPLO) Then Exit For
x.Value = arPLO(i)
i = i + 1
Next
End With
Erase arPLO
Set rBereich = Nothing: Set x = Nothing
Worksheets("PLOs COOIS").Protect ("xxxx")
End Sub

zusätzlich hätte ich eine Idee für dich
du kopierst den Code mehrfach um unterschiedliche Bereiche zu kopieren.
Mit einer kleinen Änderung könntest du den Code übersichtlicher und leichter pflegbar machen.
Wenn du der Kopierroutine PlOs_to_TTP den Bereich als Parameter übergibst, dann würde für die unterschiedlichen Bbereich nur ein kleiner Aufruf genügen

Sub KiraD()
Call PLOs_to_TTP("A13:E17")
End Sub
Sub KiraD()
Call PLOs_to_TTP("A33:E39")
End Sub

Änderung in der kopierroutine

Sub PLOs_to_TTP(sArea As String) ' der Aufruf
For Each X In .Range(sArea)  'die Anpassung an der Schleife

Sub PLOs_to_TTP(sArea As String, sMaschine As String) Dim arPLO, X As Range, rBereich As Range, sKw As String Application.ScreenUpdating = False sKw = ThisWorkbook.Worksheets("TTP").Range("G5").Value ' Wochennummer With Worksheets("PLOs COOIS") .Unprotect ("Dior.sora.1988") Set rBereich = .Range("C2:C" & .Cells(Rows.Count, "C").End(xlUp).Row) If .FilterMode Then .ShowAllData: rBereich.AutoFilter 'Vorherigen Fiter zurücksetzen 'Die Zwei Filter anwenden rBereich.Rows(1).Offset(-1).AutoFilter Field:=15, Criteria1:=sKw rBereich.Rows(1).Offset(-1).AutoFilter Field:=17, Criteria1:=sMaschine 'schleife über Filterbereich ReDim arPLO(1 To 1) cnt = 1 For Each X In rBereich.Rows If X.Height > 0 Then 'wenn Zeile sichtbar ReDim Preserve arPLO(1 To cnt) arPLO(cnt) = X.Value cnt = cnt + 1 End If Next Set X = Nothing .ShowAllData: rBereich.AutoFilter End With 'kopieren in TTP With ThisWorkbook.Worksheets("TTP") i = 1 .Range(sArea).ClearContents For Each X In .Range(sArea) If i > UBound(arPLO) Then Exit For X.Value = arPLO(i) i = i + 1 Next End With Erase arPLO Set rBereich = Nothing: Set X = Nothing Application.ScreenUpdating = True Worksheets("PLOs COOIS").Protect ("Dior.sora.1988") End Sub

'kopieren in TTP With ThisWorkbook.Worksheets("TTP") If InStr(1, sArea, ",") > 0 Then arAreas = Split(sArea, ",") Else arAreas = sArea End If i = 1 For Each y In arAreas .Range(y).ClearContents For Each X In .Range(y) If i > UBound(arPLO) Then Exit For X.Value = arPLO(i) i = i + 1 Next Next If (i - 1)

Beliebteste Forumthreads (12 Monate)

Excel VBA Werte kopieren in Bereich

29
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

316 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Excel VBA Werte kopieren in Bereich

29 Beiträge zum Forumthread Beiträge zu diesem Forumthread

316 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

29
Beiträge zum Forumthread

Beiträge zu diesem Forumthread