title image


Smiley Re: Schon gar nicht mal schlecht, aber...
Hallo Thomas,

warum nicht gleich die komplette Frage?

Hier der Code mit weiteren Erläuterungen:





      

Sub ExtraktBilden()



    Dim ws1 As Worksheet, ws2 As Worksheet

    Dim I As Long, J As Long

    Dim Durchlauf As Integer

    Dim merker

    

    Set ws1 = ActiveWorkbook.Worksheets("Daten")

    Set ws2 = ActiveWorkbook.Worksheets("Extrakt")

    

    'Löschen alten Inhalt aus dem Extrakt

    ws2.Cells.Delete

    

    I = 1: J = 0

    

    'Loop solange, bis in spalte A leere Zelle kommt

    Do Until ws1.Cells(I, 1).Value = ""

       'Wenn merker <> Firmennummer, also neue Nummer oder beim ersten Mal

       If ws1.Cells(I, 1) <> merker Then

          merker = ws1.Cells(I, 1)

          J = J + 1

          Durchlauf = 0

          'komplette Zeile übertragen

          ws1.Rows(I).Copy Destination:=ws2.Range("A" & J)

       'falls noch gleiche Firma, dann die folgenden Spalteninhalte übertragen

       Else

          'Rolle aus Spalte 2

          ws2.Cells(J, 20 + 6 * Durchlauf) = ws1.Cells(I, 2)

          'Vorname aus spalte 11

          ws2.Cells(J, 21 + 6 * Durchlauf) = ws1.Cells(I, 11)

          'Nachname aus Spalte 12

          ws2.Cells(J, 22 + 6 * Durchlauf) = ws1.Cells(I, 12)

          'Telefon aus spalte 16

          ws2.Cells(J, 23 + 6 * Durchlauf) = ws1.Cells(I, 16)

          'Fax aus Spalte 17

          ws2.Cells(J, 24 + 6 * Durchlauf) = ws1.Cells(I, 17)

          'email aus Spalte 18

          ws2.Cells(J, 25 + 6 * Durchlauf) = ws1.Cells(I, 18)

          'Falls noch weiterer Datensatz zur Firma, Durchlaufnummer erhöhen, um Offset passend zu machen

          Durchlauf = Durchlauf + 1

       End If

       I = I + 1

    Loop



End Sub

 



Code eingefügt mit Syntaxhighlighter 3.0





Paßt es jetzt?

Gruß Worti <img src="http://media2.giga.de/2015/06/snapchat-smiley-sonnenbrille.png">



geschrieben von

Login

E-Mail:
  

Passwort:
  

Beitrag anfügen

Symbol:
 
 
 
 
 
 
 
 
 
 
 
 
 

Überschrift: