Verschieben von Daten zwischen Arbeitsblättern
26.11.2023 20:42:27
boléro
Mein Macro:
Function IsValueInArray(valueToCheck As Variant, arr As Variant) As Boolean
' Function to check if a value is in an array
Dim element As Variant
For Each element In arr
If CStr(element) = CStr(valueToCheck) Then
IsValueInArray = True
Exit Function
End If
Next element
IsValueInArray = False
End Function
Sub CopyToRange()
On Error GoTo ErrorHandler ' Enable error handling
Dim sourceSheet As Worksheet
Dim destinationSheet As Worksheet
Dim valueToCheck As Variant
Dim targetRow As Range
Dim foundCell As Range
' Set the source sheet
On Error Resume Next
Set sourceSheet = Worksheets("Raiffeisen Konto")
On Error GoTo 0 ' Reset error handling
If sourceSheet Is Nothing Then
MsgBox "The source sheet 'Raiffeisen Konto' was not found.", vbExclamation
Exit Sub
End If
' Set the destination sheet
On Error Resume Next
Set destinationSheet = Worksheets("4000-7100")
On Error GoTo 0 ' Reset error handling
If destinationSheet Is Nothing Then
MsgBox "The destination sheet '4000-7100' was not found.", vbExclamation
Exit Sub
End If
' List of values to check
Dim checkValues As Variant
checkValues = Array(4000, 4010, 4550, 4700, 4710, 4740, 4750, 6000, 6400, 6700, 6900, 7100, 7200)
' Loop through each row in the source sheet
For Each sourceRow In sourceSheet.UsedRange.Rows
' Get the value to check from the source sheet (assumed to be in column D)
valueToCheck = sourceSheet.Cells(sourceRow.Row, 4).Value
' Check if the value is in the specified list of values
If IsValueInArray(valueToCheck, checkValues) Then
' Find all occurrences of the value in the A column of the destination sheet
Set foundCell = destinationSheet.Columns(1).Find(What:=valueToCheck, LookIn:=xlValues, LookAt:=xlWhole)
' Loop through each found cell and append the row from the source sheet
Do While Not foundCell Is Nothing
' Set the target row one row below the found cell
Set targetRow = foundCell.Offset(1, 0).EntireRow
' Copy the entire row from the source sheet to the destination sheet
sourceRow.Copy targetRow
' Find the next occurrence of the value in the A column of the destination sheet
Set foundCell = destinationSheet.Columns(1).FindNext(foundCell)
Loop
End If
Next sourceRow
Exit Sub ' Exit the sub if there are no errors
ErrorHandler:
MsgBox "An error occurred: " & Err.Description
End SubVielen Dank, falls mir Jemand dabei weiterhelfen kann!