Bitte um Hilfe ! Bekomme Formatierung nicht hin !

[Fennek]

Hallo,

bis auf die letzte Zeile wandelt dieser Code die Adressen in eine Zeile um:

Code:

Sub T_1()
Dim rng As Range
With Application
    .FindFormat.Font.Size = 24
    .ScreenUpdating = False
End With

With ActiveSheet.UsedRange.Columns(1)

    Set rng = .Find("*", , , , , , , , True)
        Anf = rng.Address
        
    Do
    lr = rng.Row
    Set rng = .Find("*", rng, , , , , , , True)
        Range(Range(Anf), rng.Offset(-1)).Copy
            Cells(Rows.Count, 10).End(xlUp).Offset(1).PasteSpecial Transpose:=True
        Anf = rng.Address
    Loop While rng.Row > lr
End With

Application.ScreenUpdating = True
End Sub

Das Überprüfen überlasse ich gerne anderen.

mfg

[huhu350]

@Fennek, @Rabe und alle anderen lieben Forums-Cracks !

Die Maske von Rabe wäre perfekt !

Also wenn einer das von Euch hinbekommen würde wäre das super ! :28: :28: 

Für den lieben Menschen der das hinbekommt wäre mir das sogar eine seeehr gute Flasche Wein wert ! :43: :43: 
Versprochen ! Eine Frau ein Wort ! Ein Mann ein Wörterbuch. So heißt doch der Spruch ...
Jetzt haben wir natürlich wieder das Problem mit dem Datenschutz. Ihr müsstet mir eine Adresse nennen -  huuuuuuuuuu ... 
Aber im Ernst, ich würde das dann gern w.o.g. honorieren weil ich damit komplett überfordert bin.


Einstweilen schon mal Danke für eure Bemühungen ! 

  :23: :23: :23: :23: :23: :23: :23: :23:

[Fennek]

Hallo Isabell,

die Qualität der Daten ist nicht so überragend, aber in den meisten Fällen sollte es gehen. Die Datei ist password geschützt, das sende ich dir per pn.

[WillWissen]

Hallo Fennek,

das ist für andere User, die das gleiche oder ein ähnliches Problem haben, nicht sonderlich hilfreich.

[Fennek]

Code:

Sub T_1()
Dim rng As Range
With Application
    .FindFormat.Font.Size = 24
    .ScreenUpdating = False
End With

With ActiveSheet.UsedRange.Columns(1)

    Set rng = .Find("*", , , , , , , , True)
        Anf = rng.Address
        
    Do
    lr = rng.Row
    Set rng = .Find("*", rng, , , , , , , True)
        Range(Range(Anf), rng.Offset(-1)).Copy
            Cells(Rows.Count, 10).End(xlUp).Offset(1).PasteSpecial Transpose:=True
        Anf = rng.Address
    Loop While rng.Row > lr
End With

Application.ScreenUpdating = True
End Sub

'######## kleine Helfer #########

Sub PLZ()
Sp = "Q"
    lr = Cells(Rows.Count, Sp).End(xlUp).Row
    For i = 2 To lr
        With Cells(i, Sp)
            If IsNumeric(Left(.Value, 4)) Then .Insert Shift:=xlToRight
        End With
    Next i
End Sub

Sub Tel()
Sp = "S"
    lr = Cells(Rows.Count, Sp).End(xlUp).Row
    For i = 2 To lr
        With Cells(i, Sp)
            If Left(.Value, 3) = "Tel" Then .Insert Shift:=xlToRight
        End With
    Next i
End Sub

Sub WWW()
Sp = "W"
    lr = Cells(Rows.Count, Sp).End(xlUp).Row
    For i = 2 To lr
        With Cells(i, Sp)
            If Left(.Value, 3) = "www" Then .Insert Shift:=xlToRight
        End With
    Next i
End Sub

[Rabe]

Hi Isabell,

wenn Du Deine Adressdatei, die Du im Forum hochgeladen hast (von mir wegen Datenschutz wieder aus dem Forum gelöscht), mit dem Makro von Fennek in eine Datei nach meinem Vorschlag (also jeweils alle Daten pro Person in eine Zeile) umgewandelt hast, dann bastelst Du Dir auf einem weiteren Arbeitsblatt eine Maske hin, in der dann die Daten angezeigt werden können. Jeweils die Daten in einzelne Zellen und davor oder darüber die Titel-Beschreibung, was einzugeben ist.

Wenn Du das hast, dann kannst Du die Datei mit 10-15 Dummy-Datensätzen wieder hier im Forum hochladen, dann zeigen Dir die Helfer, wie das mit dem Auslesen der Datensätze aus der Datenbank geht.
Als nächstes müssen dann die Makros erstellt werden, die Datensätze hinzufügen, ändern oder löschen. Das kommt aber erst im Nachgang.

Allgemein gesagt, ist das eine ganz normale Adressverwaltung (mit evtl. ein paar zusätzlichen Daten), von denen es im Netz Fantastillionen von Beispielen gibt. Auch hier bei uns im Forum wurde das Thema schon mehrmals angesprochen und gelöst.

Hier mal ein quick&dirty-Beispiel für die Maske mit einer intelligenten Tabelle für die Datenbank:

Arbeitsblatt mit dem Namen 'Maske'
	A	B	C	D
2	ID	Firma	Text
3	2	Testfirma	Test-Claim
4
5		Ansprechpartner
6		Anrede	Vorname	Nachname
7		Frau	Michaela	Musterfrau
8
9		Straße und Hausnummer	PLZ	Ort
10		Musterstr. 15	12345	Musterstadt
11
12		Telefon	Telefon (mobil)
13		0123/456789	0
14
15		E-Mail	Webseite / Internet
16		M.Musterfrau@domain.de	http://www.domain.de

Name	Bezug
Daten	=Tabelle1

Zelle	Formel
B3	=SVERWEIS($A$3;Daten;2;0)
C3	=SVERWEIS($A$3;Daten;3;0)
B7	=SVERWEIS($A$3;Daten;4;0)
C7	=SVERWEIS($A$3;Daten;5;0)
D7	=SVERWEIS($A$3;Daten;6;0)
B10	=SVERWEIS($A$3;Daten;7;0)
C10	=SVERWEIS($A$3;Daten;8;0)
D10	=SVERWEIS($A$3;Daten;9;0)
B13	=SVERWEIS($A$3;Daten;10;0)
C13	=SVERWEIS($A$3;Daten;11;0)
B16	=SVERWEIS($A$3;Daten;12;0)
C16	=SVERWEIS($A$3;Daten;13;0)

Verwendete Systemkomponenten: [Windows (32-bit) NT 6.01] MS Excel 2013

Diese Tabelle wurde mit Tab2Html (v2.6.0) erstellt. ©Gerd alias Bamberg

Arbeitsblatt mit dem Namen 'Datenbank'

A

B

C

D

E

F

G

H

I

J

K

L

M

2

ID

Firma / Firmierung

Claim

Anrede

Vorname

Name

Straße und Hausnummer

Postleitzahl

Stadt

Telefon

Telefon (mobil)

Mailadresse

Webseite / Internet

3

1

Konsilium Consultant KG

Always One Step Ahead!

Herr

Hans

Keris

Wankelstraße 4

70563

Stuttgart

0711-656728-101

Hans.keris@konsiliumkg.de

http://www.konsiliumkg.de

4

2

Testfirma

Test-Claim

Frau

Michaela

Musterfrau

Musterstr. 15

12345

Musterstadt

0123/456789

M.Musterfrau@domain.de

http://www.domain.de

Verwendete Systemkomponenten: [Windows (32-bit) NT 6.01] MS Excel 2013

Diese Tabelle wurde mit Tab2Html (v2.6.0) erstellt. ©Gerd alias Bamberg

Beispieldatei:
  Adress-Datensatz 2 neu.xlsb (Größe: 13,59 KB / Downloads: 1)