Zeilen kopieren

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

AW: Zeilen kopieren

24.01.2007 23:01:16

Anton

AW: Zeilen kopieren

24.01.2007 23:03:07

Josef

AW: Zeilen kopieren

24.01.2007 23:06:21

Josef

Hallo Pricki,
ich bin davon ausgegangen, das in der Quell- und Zieltabelle, in der ersten Zeile jeweils Überschriften stehen.
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub pricki()
    Dim objSh1 As Worksheet, objSh2 As Worksheet
    Dim vTmp As Variant, vVal() As Variant
    Dim lngR As Long, lngI As Long
    Dim intC As Integer

    Set objSh1 = Sheets("Tabelle1") ' Tabelle mit der MA-Liste
    Set objSh2 = Sheets("Tabelle2") ' Ausgabetabelle
    'Tabellennamen anpassen

    objSh2.Range("A2:IV65536").ClearContents

    With objSh1
        lngR = .Cells(Rows.Count, 1).End(xlUp).Row
        intC = .Cells(1, Columns.Count).End(xlToLeft).Column
        vTmp = .Range(.Cells(1, 1), .Cells(lngR, intC))
    End With

    Redim vVal(lngR * intC, 1 To 3)

    For lngR = 2 To UBound(vTmp, 1)
        For intC = 2 To UBound(vTmp, 2)
            If vTmp(lngR, intC) <> "" Then
                lngI = lngI + 1
                vVal(lngI, 1) = vTmp(lngR, 1)
                vVal(lngI, 2) = vTmp(1, intC)
                vVal(lngI, 3) = vTmp(lngR, intC)
            End If
        Next
    Next

    With objSh2
        If lngI > 0 Then
            .Range("A2:C" & lngI + 2) = vVal
        End If
    End With

    Set objSh1 = Nothing
    Set objSh2 = Nothing
End Sub

Gruß Sepp

Hallo nochmal,
eine kleine Korrektur.
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub pricki()
    Dim objSh1 As Worksheet, objSh2 As Worksheet
    Dim vTmp As Variant, vVal() As Variant
    Dim lngR As Long, lngI As Long
    Dim intC As Integer

    Set objSh1 = Sheets("Tabelle1") ' Tabelle mit der MA-Liste
    Set objSh2 = Sheets("Tabelle2") ' Ausgabetabelle
    'Tabellennamen anpassen

    objSh2.Range("A2:IV65536").ClearContents

    With objSh1
        lngR = .Cells(Rows.Count, 1).End(xlUp).Row
        intC = .Cells(1, Columns.Count).End(xlToLeft).Column
        vTmp = .Range(.Cells(1, 1), .Cells(lngR, intC))
    End With

    Redim vVal(1 To (lngR - 1) * (intC - 1), 1 To 3)

    For lngR = 2 To UBound(vTmp, 1)
        For intC = 2 To UBound(vTmp, 2)
            If vTmp(lngR, intC) <> "" Then
                lngI = lngI + 1
                vVal(lngI, 1) = vTmp(lngR, 1)
                vVal(lngI, 2) = vTmp(1, intC)
                vVal(lngI, 3) = vTmp(lngR, intC)
            End If
        Next
    Next

    With objSh2
        If lngI > 0 Then
            .Range("A2:C" & lngI + 1) = vVal
        End If
    End With

    Set objSh1 = Nothing
    Set objSh2 = Nothing
End Sub

Gruß Sepp

Beliebteste Forumthreads (12 Monate)

3 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

3
Beiträge zum Forumthread

Beiträge zu diesem Forumthread