2-dimensionales Datenfeld in Excel-Tabelle eintragen Mit diesem Code lässt sich schnell und komfortabel ein 2-dimensionales Daten-Array in ein Excel-Tabellenblatt bringen.
Autor:   Friedrich Grath	Bewertung:     [ Jetzt bewerten ]	Views:  33.259
ohne Homepage	System:  Win9x, WinNT, Win2k, WinXP, Vista, Win7, Win8, Win10	kein Beispielprojekt

Geben Sie hier Ihre persönliche Bewertung ab! Anzahl Bewertungen bisher: 34 Bewertung insgesamt: nützlich Durchschnittliche Bewertung: 2.6 von 5 Sternen

sehr gut     gut     nützlich     mittelmäßig     mangelhaft

Mit nachfolgendem Code lässt sich unter Zuhilfenahme der Zwischenablage schnell und komfortabel ein 2-dimensionales Datenfeld (Array(x,y)) in ein Excel-Tabellenblatt bringen.

' WICHTIG:
' Microsoft Forms 2.0 Object Library unter Extras\Verweise setzen
 
' 2-dimensionales DATENFELD in EXCELTABELLE eintragen
' -------------------------------------------------------------------------
' 
' Sehr schnelles und komfortables Eintragen der Daten eines 2-dimensionalen
' Datenfeldes (Datenfeld(x,y)) in ein Excel-Tabellenblatt (horizontale oder
' vertikale Richtung) mit Hilfe der Zwischenablage.
' 
' Funktionsweise:
' Mit den Daten eines 2-dimensionalen Datenfeldes (Daten(x,y)) wird ein
' String gebildet und dann über die Zwischenablage in die Tabelle eingetragen.
' -------------------------------------------------------------------------
' 
' Aufruf: Call Daten_in_Tabelle(Datenfeld(), Startzelle, Tabelle, Richtung)
' 
' Datenfeld() ---> Datenfeld(x, y), Datentyp Variant
' Startzelle ---> linke oberste Zelle
' Tabelle ---> Exceltabelle, in die die Daten geschrieben werden
' 5 ---> fünftes Tabellenblatt
' keine Angabe ---> aktives Tabellenblatt
' Richtung 1 ---> Datenrichtung der 1. Dimension horizontal
' 0 ---> Datenrichtung der 1. Dimension vertikal
' keine Angabe ---> Datenrichtung der 1. Dimension vertikal
 
' Beispiele für den Aufruf:
' Call Daten_in_Tabelle(Daten(), "A1")
' Call Daten_in_Tabelle(Daten(), "C4", 2)
' Call Daten_in_Tabelle(Daten(), "B17", "Tabelle3")
' Call Daten_in_Tabelle(Daten(), "X19", "Tabelle3", 1)
' 
' -------------------------------------------------------------------------
 
Function Daten_in_Tabelle(FELD(), startZELLE As String, _
  Optional TABELLE As Variant, _
  Optional RICHTUNG As Byte = 0)
 
  Dim x&, y&, Zeile$, Matrix$, Clip As DataObject
 
  Set Clip = New DataObject
 
  On Error GoTo PROC_EXIT
  Application.ScreenUpdating = False
 
  ' wenn keine Tabellenbezeichnung, dann aktive Tabelle
  If IsMissing(TABELLE) Then TABELLE = ActiveSheet.Name
 
  ' In die Tabelle eintragen
  If RICHTUNG = 0 Then ' horizontale Datenrichtung
    For x = LBound(FELD(), 1) To UBound(FELD(), 1)
      Zeile = vbNullString
      For y = LBound(FELD(), 2) To UBound(FELD(), 2)
        If y <> UBound(FELD(), 2) Then
          Zeile = Zeile & FELD(x, y) & Chr(9)
        Else
          Zeile = Zeile & FELD(x, y)
        End If
      Next y
      Matrix = Matrix + Zeile + Chr(13)
    Next x
 
  Else ' vertikale Datenrichtung
    For y = LBound(FELD(), 2) To UBound(FELD(), 2)
      Zeile = vbNullString
      For x = LBound(FELD(), 1) To UBound(FELD(), 1)
        If x <> UBound(FELD(), 1) Then
          Zeile = Zeile & FELD(x, y) & Chr(9)
        Else
          Zeile = Zeile & FELD(x, y)
        End If
      Next x
      Matrix = Matrix + Zeile + Chr(13)
    Next y
  End If
 
  With Clip
    .Clear ' Zwischenablage löschen
    .SetText Matrix
    .PutInClipboard
  End With
 
  With Worksheets(TABELLE)
    ' Eingabebereich der Tabelle löschen
    x = Range(startZELLE).Row
    y = Range(startZELLE).Column
 
    If RICHTUNG = 0 Then
      .Range(Cells(x, y), _
        Cells(x + UBound(FELD(), 1) - LBound(FELD(), 1), _
        y + UBound(FELD(), 2) - LBound(FELD(), 2))).ClearContents
    Else
      .Range(Cells(x, y), _
        Cells(x + UBound(FELD(), 2) - LBound(FELD(), 2), _
        y + UBound(FELD(), 1) - LBound(FELD(), 1))).ClearContents
    End If
 
    .Range(startZELLE).Select
    .Paste
    .Range(startZELLE).Select
  End With
 
PROC_EXIT:
  Set Clip = Nothing
  Application.ScreenUpdating = True
End Function

Aufrufbeispiel:

Sub Aufruf()
  Dim datenArray(1 To 250, 1 To 200)
  Dim n&
 
  ' Füllen des Datenarrays (50000 Elemente)
  For x = 1 To 250
    For y = 1 To 200
      datenArray(x, y) = n
      n = n + 1
    Next y
  Next x
 
  ' Aufruf
  Call Daten_in_Tabelle(datenArray(), "A1", "Tabelle1", 0)
End Sub