Thema Datum  Von Nutzer Rating
Antwort
20.06.2021 11:36:30 Yannick
NotSolved
20.06.2021 13:18:59 Gast24717
NotSolved
20.06.2021 16:14:41 Yannick
NotSolved
21.06.2021 15:18:36 Gast6711
NotSolved
21.06.2021 15:25:10 Gast58526
NotSolved
Blau Zellenwerte überschreiben & verteilen
21.06.2021 18:40:49 Gast8353
NotSolved
20.06.2021 13:19:41 Mase
Solved

Ansicht des Beitrags:
Von:
Gast8353
Datum:
21.06.2021 18:40:49
Views:
232
Rating: Antwort:
  Ja
Thema:
Zellenwerte überschreiben & verteilen
Option Explicit
  
Private Const wsBaseName As String = "Tabelle"
Private Const idBaseName As String = "ABC"

Public Function GetUniqueCustomerIdList() As Object
  
  Dim wks As Excel.Worksheet
  Dim rngData As Excel.Range
  Dim rngCID As Excel.Range
  Dim dic As Object
  Dim n As Long
  
  Set dic = CreateObject("Scripting.Dictionary")
  dic.CompareMode = VbCompareMethod.vbTextCompare
  
  For Each wks In Worksheets
    ' Only if the worksheet name starts with 'wsBaseName'
    ' and ignoring case ('TaBeLlE = Tabelle').
    If 0 = StrComp(Left$(wks.Name, Len(wsBaseName)), wsBaseName, vbTextCompare) Then
      
      Set rngData = GetDataRange(Array("customer_id", "CID", "CUST_ID"), wks)
      
      If rngData Is Nothing Then
        Debug.Print "customer id column not found - worksheet: '"; wks.Name; "'"
      Else
        For Each rngCID In rngData.Cells
          If Not dic.Exists(rngCID.Value) Then
            n = n + 1
            Debug.Print "adding ['"; CStr(rngCID.Value); "' := '"; idBaseName & n; "'] to list"
            dic(rngCID.Value) = idBaseName & n
          End If
        Next
      End If
      
    End If
  Next
  
  Set GetUniqueCustomerIdList = dic
  Set dic = Nothing
  
End Function

Private Function GetDataRange(ColumnNames As Variant, Worksheet As Excel.Worksheet) As Excel.Range
  Dim rngCID As Excel.Range
  
  Set rngCID = GetCell(ColumnNames, Worksheet)
  
  If Not rngCID Is Nothing Then
    
    Dim rngFirst As Excel.Range
    Dim rngLast As Excel.Range
    
    Set rngLast = Worksheet.Cells(Worksheet.Cells.Rows.Count, rngCID.Column).End(xlUp)
    
    If rngCID.Offset(1).Value <> "" Then
      Set rngFirst = rngCID.Offset(1)
    Else
      Set rngFirst = rngCID.End(xlDown)
    End If
    
    If rngFirst.Row <= rngLast.Row Then
      Set GetDataRange = Worksheet.Range(rngFirst, rngLast)
    End If
  End If
  
End Function

Private Function GetCell(CellValue As Variant, Worksheet As Excel.Worksheet) As Excel.Range
  
  If Worksheet Is Nothing Then Exit Function
  
  Dim rngMatch As Excel.Range
  Dim vntCells As Variant
  Dim vntCell As Variant
  
  If IsArray(CellValue) Then
    vntCells = CellValue
  Else
    vntCells = Array(CellValue)
  End If
  
  For Each vntCell In vntCells
    Set rngMatch = Worksheet.Cells.Find(vntCell, , xlValues, xlWhole, xlByRows, xlNext, False)
    If Not rngMatch Is Nothing Then
      Set GetCell = rngMatch
      Exit Function
    End If
  Next
  
End Function

Jetzt hast du die Wahl der Qual, ob du das Ersetzen direkt GetUniqueCustomerIdList gleich mit machen möchtest (in dem Fall würd ich die Funktion umbenennen), oder ob du in einer weiteren Funktion die Ersetzungen vornimmst, anhand der gewonnen Liste.

 


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
20.06.2021 11:36:30 Yannick
NotSolved
20.06.2021 13:18:59 Gast24717
NotSolved
20.06.2021 16:14:41 Yannick
NotSolved
21.06.2021 15:18:36 Gast6711
NotSolved
21.06.2021 15:25:10 Gast58526
NotSolved
Blau Zellenwerte überschreiben & verteilen
21.06.2021 18:40:49 Gast8353
NotSolved
20.06.2021 13:19:41 Mase
Solved