Transport von Zellwerten

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub Harztransport() Dim Was Dim Ziel Dim ZWas As Range Dim ZZiel As Range Was = Range("G3").Value Ziel = Range("G5").Value 'Suche Inhalt von G3 Range("A1").Select Set ZZiel = Cells.Find(What:=Ziel, LookAt:=xlWhole, SearchDirection:=xlNext, SearchOrder:=xlByColumns, MatchCase:=False, SearchFormat:=False) If ZZiel Is Nothing Then MsgBox "Wert """ & Ziel & """ nicht gefunden." Else 'In der gefundene Spalte, suche Inhalt von G5 Range("A1").Select Set ZWas = ZZiel.EntireColumn.Find(What:=Was, LookAt:=xlWhole, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False) If ZWas Is Nothing Then MsgBox "Wert """ & Was & """ in der Splate " & Chr(64 + ZZiel.Column) & " nicht gefunden." Else ZZiel.Offset(1, 0) = Was ZWas.ClearContents End If End If End Sub

Sub Transport() Dim Zeile As Long Dim Spalte As Long Dim Was As String Dim arr As Variant Dim SOffset As Long Dim ZOffset As Long arr = Range("a3:d6") ZOffset = 0 SOffset = 0 Was = Range("g3").Value For Zeile = LBound(arr) To UBound(arr) For Spalte = LBound(arr, 2) To UBound(arr, 2) If arr(Zeile, Spalte) Like Was Then SOffset = Spalte ZOffset = Zeile End If Next Next Range("a3").Offset(ZOffset, SOffset).Cut Select Case Range("G5").Value Case "AT1": Range("A9").PasteSpecial xlPasteAll Case "AT2": Range("B9").PasteSpecial xlPasteAll Case "Beh.1": Range("C9").PasteSpecial xlPasteAll Case "Beh.2": Range("D9").PasteSpecial xlPasteAll End Select End Sub

Sub Transport() Dim Zeile As Long Dim Spalte As Long Dim Was As String Dim arr As Variant Dim SOffset As Long Dim ZOffset As Long arr = Range("a3:b6") ZOffset = 0 SOffset = 0 Was = Range("g3").Value For Zeile = LBound(arr) To UBound(arr) For Spalte = LBound(arr, 2) To UBound(arr, 2) If arr(Zeile, Spalte) Like Was Then SOffset = Spalte - 1 ZOffset = Zeile - 1 End If Next Next Range("a3").Offset(ZOffset, SOffset).Cut Select Case Range("G5").Value Case "AT1": Range("A9").PasteSpecial xlPasteValues Case "Beh.1": Range("B9").PasteSpecial xlPasteValues End Select End Sub

Hallo Steve,
ein Copy-PasteValue ist für eine einzelne Werte ein bisschen over-engineered. Bei mehrere Zelle schon.
Der Umweg über einen Array ist nur sinnvoll, wenn man mehrere Werte auf einmal ablegen möchte. Ein Excel-Bereich ist auch ein Array und nur lesend gibt es keine Performance-Einbusse.


Sub Transport()
Dim Was As String
Dim gefunden As Boolean
Was = Range("g3").Value
For Each Z In Range("a3:b6").Cells
If Z.Value Like Was Then
gefunden = True
Exit For
End If
Next
If gefunden Then
Select Case Range("G5").Value
Case "AT1": Range("A9") = Z.Value
Case "Beh.1": Range("B9") = Z.Value
End Select
End If
End Sub

Einzige Problem: mit deinem Vorschlag wrid immer die letzt gefunden Zelle, Falls der "Was" mehrmals vorhanden wäre, genommen. Bei meiner immer die erste Zelle.
Wenn die letzte genommen werden soll:


Sub Transport()
Dim Was As String
Dim gefunden As Range
Was = Range("g3").Value
For Each Z In Range("a3:b6").Cells
If Z.Value Like Was Then
Set gefunden = Z
End If
Next
If Not gefunden Is Nothing Then
Select Case Range("G5").Value
Case "AT1": Range("A9") = gefunden.Value
Case "Beh.1": Range("B9") = gefunden.Value
End Select
End If
End Sub

VG
Yal

Beliebteste Forumthreads (12 Monate)

4 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread