Thema Datum  Von Nutzer Rating
Antwort
30.08.2017 16:03:20 Lutz
NotSolved
30.08.2017 16:38:55 Mackie
NotSolved
30.08.2017 17:44:55 Gast70117
NotSolved
Blau Korrektur
30.08.2017 18:09:50 Gast70117
NotSolved
05.09.2017 08:41:46 Gast44156
NotSolved

Ansicht des Beitrags:
Von:
Gast70117
Datum:
30.08.2017 18:09:50
Views:
659
Rating: Antwort:
  Ja
Thema:
Korrektur

hab vergessen, dass der Offset hier angepasst werden muss

Option Explicit

Sub Tab1To2()
'aktive Mappe hat 2 Tabellen - hier "Tabelle1", "Tabelle2"
Dim rngU As Range, x As Long
Dim arrB() As Variant, rngZ As Range

   '2. leeren
   Sheets("Tabelle2").Cells.Clear
   'brutal
   Sheets("Tabelle1").Cells.Copy Sheets("Tabelle2").Cells(1)
   

   With Sheets("Tabelle2")
      Set rngU = .UsedRange
      'wir haben Kopfzeilen
      Set rngU = rngU.Offset(1).Resize(rngU.Rows.Count - 1)
      'Spalten verdichten
      arrB = GetDistinct(rngU)
      'ausgeben Unikate
      Set rngZ = .Cells(1, rngU.Columns.Count + 2)
      rngZ.Value = "Fall"
      rngZ.Offset(, 1).Value = "Anzahl"
      rngZ.Offset(1).Resize(UBound(arrB) + 1, 1).Value = Application.Transpose(arrB)
      'zählen und ausgeben Unikate
      For x = LBound(arrB) To UBound(arrB)
         If arrB(x) <> "" Then
            rngZ.Offset(x + 1, 1).Value = WorksheetFunction.CountIf(rngU, arrB(x))
         End If
      Next x
      .Columns.AutoFit
   End With

End Sub

''
Private Function GetDistinct(ByVal oTarget As Range) As Variant
''Zweck Dupplikate in gegebenen Bereich entfernen, als Array
''posted by Craig Hatmaker
Dim varArray As Variant
Dim objMyDic As Object
Dim V        As Variant
Dim x As Long
'
  Set objMyDic = CreateObject("Scripting.Dictionary")
  varArray = oTarget
  For Each V In varArray
    objMyDic(V) = V
    x = x + 1
  Next
  GetDistinct = objMyDic.Items()
  Debug.Print x
End Function

 


Ihre Antwort
  • Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
  • Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
  • Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen
Thema: Name: Email:



  • Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
  • Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
  • Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen

Thema Datum  Von Nutzer Rating
Antwort
30.08.2017 16:03:20 Lutz
NotSolved
30.08.2017 16:38:55 Mackie
NotSolved
30.08.2017 17:44:55 Gast70117
NotSolved
Blau Korrektur
30.08.2017 18:09:50 Gast70117
NotSolved
05.09.2017 08:41:46 Gast44156
NotSolved