dyn. Tab - best. Bereich markieren

Hi,
ich benötige dringend Eure Hilfe. Nun zu meinem Problem. Ich möchte gerne eine Adressdatei erstellen. Leider wurden die Daten von einer Kollegin auf einzelne Tabellenblätter geschrieben,... und dann noch untereinander.
Das jeweilige Tabellenblatt sieht folgendermaßen in Excel aus (P.S. kann hier leider keine Spalten einfügen, daher die Punkte....:-()
....... A.........................B............................. C
1..... Name:.................Müller
2..... Tel:.....................040/12345
3................................................................
4..... Kenntnisse:........ Excel
5.................................VBA
6.................................Word
7
8..... Hobbies: .......... Bogenschießen
9.................................Musik
10...............................Lesen
11
12
13
14
Dabei ist zu beachten, dass der Bereich Kenntnisse und Hobbies zudem noch unterschiedlich lang sein können.
Also: folgendes soll Excel mithilfe VBA automatisch machen: Es soll den Bereich Kenntnisse (Spalte A + B), sowie den Bereich Hobbies (..die Bereiche können unterschiedlich lang sein) jeweils auf 15 Zeilen pro Bereich erweitern... also vereinheitlichen.
Anschließend soll er die nun veränderte Tabelle1 (Tabellenblatt hat den Namen: Namen) in das Tabellenblatt 2 (Adressen) kopieren.
Bei diesem Vorgang sollen die Daten jeweils transponiert werden. Immer wenn neue Adressen in dieses Tabellenblatt eingefügt werden, soll er die neuen Daten (aus der Spalte B - also ohne die Bezeichnungen) in die nächste freie Zeile kopieren, so dass sich nach und nach eine vollständige Adressdatei ergibt.
Ich hoffe sehr, dass ihr mir bei diesem für mich bisher unlösbaren Problem helft.
Merci vorab
Zira

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Zira,
probier mal.
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub DatenUmschaufeln()
    Dim objWsAdr As Worksheet, objWs As Worksheet
    Dim lngNext As Long, lngR As Long, lngC As Long, lngOffset
    Dim rng As Range

    Set objWsAdr = Sheets("Adressen")
    With objWsAdr

        For Each objWs In ThisWorkbook.Worksheets
            If Not objWs Is objWsAdr Then
                lngNext = Application.Max(2, .Cells(Rows.Count, 1).End(xlUp).Row + 1)
                For lngC = 1 To 25
                    If .Cells(2, lngC) <> "" And Right(.Cells(2, lngC), 1) = ":" Then
                        Set rng = objWs.Range("A:A").Find(What:=.Cells(2, lngC), LookAt:=xlWhole, After:=objWs.Cells(Rows.Count, 1))

                        If Not rng Is Nothing Then
                            If lngC < 7 Then
                                .Cells(lngNext, lngC) = rng.Offset(0, 1)
                            Else
                                Do
                                    .Cells(lngNext, lngC + lngOffset) = rng.Offset(lngOffset, 1)
                                    lngOffset = lngOffset + 1
                                Loop While rng.Offset(lngOffset, 1) <> ""
                                lngOffset = 0
                            End If
                        End If
                    End If
                Next
            End If
        Next

    End With
End Sub

Gruß Sepp

Beliebteste Forumthreads (12 Monate)

dyn. Tab - best. Bereich markieren

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