Microsoft Excel

Herbers Excel/VBA-Archiv

Zellbereich per VBA übertragen | Herbers Excel-Forum


Betrifft: Zellbereich per VBA übertragen von: Fritz_W
Geschrieben am: 18.02.2012 11:42:46

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

  

Betrifft: AW: Zellbereich per VBA übertragen von: Josef Ehrensberger
Geschrieben am: 18.02.2012 12:13:28


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 »



  

Betrifft: AW: Zellbereich per VBA übertragen von: Fritz_W
Geschrieben am: 18.02.2012 12:33:55

Hallo Sepp!

Funktioniert excellent, einfach super deine Hilfen!!
Ganz herzlichen Dank und schöne Grüße

Fritz


  

Betrifft: @Sepp von: Fritz_W
Geschrieben am: 18.02.2012 14:57:22

Hallo Sepp,

ich hätte doch noch einen (in dieser Sache vermutlich letzten) Wunsch.
Das obige Makro sollte nur ausgeführt werden, wenn Zelle B2 der Tabelle1 ein 'x' enthält.
Wäre nett, wenn sich das noch realisieren ließe.

Dank im Voraus.

Beste Grüße
Fritz


  

Betrifft: AW: @Sepp von: Josef Ehrensberger
Geschrieben am: 18.02.2012 16:30:00


Hallo Fritz,

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







« Gruß Sepp »



  

Betrifft: AW: @Sepp von: Fritz_W
Geschrieben am: 18.02.2012 17:40:42

Hallo Sepp,

irgendetwas stimmt nicht, ich vermute, der Code bezieht sich auf Zelle B2 in Tabelle2 anstatt auf B2 der Tabelle1. Wenn ja, was müsste man ändern?

Viele Grüße
Fritz


  

Betrifft: hab ich doch schon gepostet! von: Josef Ehrensberger
Geschrieben am: 18.02.2012 17:44:40

https://www.herber.de/forum/messages/1251363.html

« Gruß Sepp »



  

Betrifft: Korrektur von: Josef Ehrensberger
Geschrieben am: 18.02.2012 16:31:36


Hallo Fritz,

sollte ja B2 in Tabelle1 sein

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






« Gruß Sepp »



  

Betrifft: AW: Korrektur von: Fritz_W
Geschrieben am: 18.02.2012 19:32:55

Hallo Sepp,

irgendwie ist mein Posting 'untergetaucht', hab es erst jetzt bemerkt. Sorry.
Funktioniert inzwischen tadellos.

Nochmals besten Dank und viele Grüße
Fritz


Beiträge aus den Excel-Beispielen zum Thema "Zellbereich per VBA übertragen"