Zellbereich per VBA übertragen

Hallo Forumsbesucher,
ich hoffe um Unterstützung der VBA-Experten unter euch:
In der Tabelle2 befinden sich in der Spalte A Zahlen (jede Zahl kommt aber nur 1x vor).
In der Tabelle1 können in die Zelle I1 nur Zahlen eingegeben werden, die eben auch in der Spalte A der Tabelle2 vorkommen.
Ich würde gern per Makro nun folgendes bewerkstelligen:
Das Makro sollte den Zellbereich D3:D18 der Tabelle1 kopieren und als Werte (unformatiert) in die Tabelle2 einfügen und zwar beginnend in der Zeile der Tabelle2 in der in der Spalte A die gleiche Zahl steht, die auch in I1 der Tabelle1 steht. Da in Tabelle2 schon Werte enthalten sind sollte in die Spalte kopiert werden, die als erste in der betreffenden Zeile 'leer' ist.
Beispiel:
Zur Zeit der Ausführung des Makros enthält die Zelle I1 in Tabelle1 den Wert 4.
Die Zahl 4 steht in Tabelle2 in der Zelle A53. Die erste leere Spalte der Zeile 53 in Tabelle2 ist (zum Zeitpunkt der Ausführung des Makros) die Spalte G.
Die Werte des Zellbereichs D3:18 aus Tabelle1 sollten nun in den Zellbereich G53:G68 der Tabelle2 eingefügt werden.
Ich hoffe, dass ich mein Anliegen nachvollziehbar dargestellt habe und freue mich über eure Hilfe.
mfg
Fritz

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

Hallo Fritz,
so?

' **********************************************************************
' Modul: Modul1  Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub fritz()
  Dim vntRet As Variant, vntValues As Variant
  Dim rngFree As Range
  
  With Sheets("Tabelle2")
    If Sheets("Tabelle1").Range("I1") <> "" Then
      vntRet = Application.Match(Sheets("Tabelle1").Range("I1"), .Columns(1), 0)
      If IsNumeric(vntRet) Then
        Set rngFree = FirstEmptyCell(.Rows(vntRet))
        If Not rngFree Is Nothing Then
          vntValues = Sheets("Tabelle1").Range("D3:D18")
          rngFree.Resize(UBound(vntValues, 1), 1) = vntValues
        End If
      End If
    End If
  End With
  
End Sub


Private Function FirstEmptyCell(Target As Range, Optional Reverse As Boolean = False) As Range
  Dim vntRet As Variant, strRef As String
  
  With Target
    strRef = "'" & .Parent.Name & "'!" & .Address
    vntRet = Evaluate(IIf(Reverse, "MAX", "MIN") & "(IF(" & strRef & "="""",ROW(" & strRef & _
      ")+COLUMN(" & strRef & ")*10^-6))")
    If IsError(vntRet) Or vntRet = 0 Then Exit Function
    Set FirstEmptyCell = .Cells(Clng(Split(vntRet, ",")(0)) - .Rows(1).Row + 1, Clng(Split(vntRet, _
      ",")(1)) - .Columns(1).Column + 1)
  End With
End Function

« Gruß Sepp »

Sub fritz() Dim vntRet As Variant, vntValues As Variant Dim rngFree As Range With Sheets("Tabelle2") If .Range("B2") = "x" Then If Sheets("Tabelle1").Range("I1") <> "" Then vntRet = Application.Match(Sheets("Tabelle1").Range("I1"), .Columns(1), 0) If IsNumeric(vntRet) Then Set rngFree = FirstEmptyCell(.Rows(vntRet)) If Not rngFree Is Nothing Then vntValues = Sheets("Tabelle1").Range("D3:D18") rngFree.Resize(UBound(vntValues, 1), 1) = vntValues End If End If End If End If End With End Sub

Sub fritz() Dim vntRet As Variant, vntValues As Variant Dim rngFree As Range With Sheets("Tabelle2") If Sheets("Tabelle1").Range("I1") <> "" And Sheets("Tabelle1").Range("B2") = "x" Then vntRet = Application.Match(Sheets("Tabelle1").Range("I1"), .Columns(1), 0) If IsNumeric(vntRet) Then Set rngFree = FirstEmptyCell(.Rows(vntRet)) If Not rngFree Is Nothing Then vntValues = Sheets("Tabelle1").Range("D3:D18") rngFree.Resize(UBound(vntValues, 1), 1) = vntValues End If End If End If End With End Sub

Beliebteste Forumthreads (12 Monate)

8 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread