SHARE
TWEET

Krissi helpen

a guest Feb 27th, 2020 91 Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
  1. Sub Datenkombienation()
  2. '
  3. ' Datenkombienation Makro
  4. '
  5. ' Tastenkombination: Strg+Umschalt+M
  6. '
  7.    Dim lQuellZeile As Long
  8.    Dim lZielZeile As Long
  9.    Dim lSpalte As Long
  10.    Dim lSuchZeile As Long
  11.    Dim oQuelle As Object
  12.    Dim oZiel As Object
  13.    Dim bFlag As Boolean
  14.    Dim sVergleichQuelle As String
  15.    Dim sVergleichZiel As String
  16.    Dim Zelle As Range
  17.    Dim Zaehler As Long
  18.    Dim oTargetSheet As Object
  19.    Dim oSheet As Object
  20.    Dim lErgebnisZeile As Long
  21.    Dim i As Long
  22.    Dim z As Long
  23.    Dim s As Long
  24.      
  25.      Set oQuelle = Sheets("SCL-90") 'Arbeitsblatt festlegen, auf dem die Daten kombiniert werden
  26.      
  27.      Set oZiel = Sheets.Add 'Neues Arbeitsblatt erstellen auf dem die Daten gespeichert werden
  28.      lZielZeile = 2 'Neue Daten werden in der zweiten Zeile eingef?hrt
  29.      
  30.      Application.ScreenUpdating = False 'Flackern ausschalten
  31.      
  32.      '?berschriften eintragen
  33.      For lSpalte = 1 To 90
  34.          oZiel.Cells(1, lSpalte).Value = oQuelle.Cells(1, lSpalte).Value
  35.      Next lSpalte
  36.      
  37.      'Konsolidierung
  38.      For lQuellZeile = 2 To oQuelle.UsedRange.Rows.Count + oQuelle.UsedRange.Row - 1
  39.      
  40.          bFlag = False
  41.          
  42.          'Pr?fen ob Zeile schon vorhanden
  43.          For lSuchZeile = 2 To oZiel.UsedRange.Rows.Count + oZiel.UsedRange.Row - 1
  44.              sVergleichQuelle = ""
  45.              sVergleichZiel = ""
  46.              For lSpalte = 1 To 4
  47.                  sVergleichQuelle = sVergleichQuelle & CStr(oQuelle.Cells(lQuellZeile, lSpalte).Text)
  48.                  sVergleichZiel = sVergleichZiel & CStr(oZiel.Cells(lSuchZeile, lSpalte).Text)
  49.              Next lSpalte
  50.              If LCase(Trim(CStr(sVergleichQuelle))) = LCase(Trim(CStr(sVergleichZiel))) Then
  51.                  bFlag = True
  52.                  Exit For
  53.              End If
  54.          Next lSuchZeile
  55.          
  56.          'Pr?fergebnis entscheidet ob bereits vorhanden oder eine neue Zeile angelegt werden muss
  57.          If bFlag = True Then 'Bereits vorhanden also nur anh?ngen
  58.              oZiel.Cells(lSuchZeile, 5).Value = oZiel.Cells(lSuchZeile, 5).Text & _
  59.                  ", " & oQuelle.Cells(lQuellZeile, 5).Text
  60.          Else 'Zeile als neu unten anh?ngen
  61.              For lSpalte = C1 To AC1
  62.                  'Inhalt ?bertragen ein f?hrendes ' erzwingt die Text?bernahme!!!
  63.                  For Each Zelle In oQuelle.Range("C1:AC1")
  64.                  oZiel.Cells(Zaehler, 1) = Zelle
  65.                  Zaehler = Zaehler + 30
  66.              lZielZeile = lZielZeile + 1
  67.               Next lZeile
  68.                 End If
  69.          Next lSpalte
  70.          
  71.          End Sub
RAW Paste Data
We use cookies for various purposes including analytics. By continuing to use Pastebin, you agree to our use of cookies as described in the Cookies Policy. OK, I Understand
Top