|
Hallo zusammen,
es handelt sich um folgende Problemstellung:
Insgesamt existieren ca. 1000 verschiedene "customer_ids". Diese können in der Datei auf mehreren worksheets auch mehrmals auftreten.
Die Datensätze "customer_id" sollen automatisch mit einer neuen Bezeichnung überschrieben werden. Die Bezeichnung stellt ein Format aus einer festen Reihenfolge von Buchstaben + einer fortlaufend, aufsteigenden Zahl dar -> ABC1, ABC2, ..., ABCn. Siehe Abbildung links-oben.
Dabei kann sowohl der Name der Spalte, in denen sich die IDs befinden als auch deren Position auf den verschiedenen worksheets variieren. D.h. die "customer_id" findet sich auch als "cid" und "cust_id" auch in anderen Spalten als "A" wider. Vgl. Abbildungen.
Die wiederkehrenden customer_id's sollen auf allen worksheets dieselbe Bezeichnung haben, vgl. Abbildungen.
Die folgende Excel-Datei ist eine beispielhafte Darstellung:
Bisher habe ich die folgenden beiden Codes, mit denen ich es allerdings nicht realisieren kann auch die Datensätze zu editieren, die sich nicht in der Spalte "A" befinden. Außerdem werden die Einträge einer Spalte mit anderen Datensätzen, die sich in "A" befinden überschrieben.Das Ergebnis stelle ich in den Abbildungen unter dem Code vor.:
Option Explicit
Sub ChangeID()
Const idBaseName As String = "ABC"
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
dict.CompareMode = vbTextCompare ' ignore case of 'idBaseName'
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim ws As Worksheet
Dim rg As Range
Dim cCell As Range
Dim Key As Variant
Dim lRow As Long
Dim n As Long
For Each ws In wb.Worksheets
' Only if the worksheet name starts with 'wsBaseName'
' and ignoring case ('TaBeLlE = Tabelle').
lRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
If lRow > 1 Then ' check if any id's
Set rg = ws.Range("A2:A" & lRow)
For Each cCell In rg.Cells
Key = CStr(cCell.Value)
If Not dict.Exists(Key) Then
n = n + 1
dict.Add Key, idBaseName & n
End If
cCell.Value = dict(Key)
Next cCell
End If
Next ws
MsgBox "Done.", vbInformation, "Change ID"
End Sub
Sub ChangeIDPart2()
Const idBaseName As String = "ABC"
Const ColNamesList As String = "cid, customer_id, ids, cust_id" ' add more
Const HeaderRow As Long = 1
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim fRow As Long: fRow = HeaderRow + 1
Dim ColNames() As String: ColNames = Split(ColNamesList, ",")
Dim cUpper As Long: cUpper = UBound(ColNames)
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
dict.CompareMode = vbTextCompare ' ignore case of 'idBaseName'
Dim ws As Worksheet ' Current Worksheet
Dim rrg As Range ' Entire Row of Headers
Dim rg As Range ' ID Column Range
Dim cCell As Range ' Current Cell in ID Column Range
Dim cIndex As Variant ' Current ID Column (could be an error value)
Dim Key As Variant ' Current ID (string)
Dim lRow As Long ' ID Column Last Non-Empty (Not Hidden) Row
Dim n As Long ' New ID Incrementer
Dim i As Long ' Column Names (Titles, Headers) Counter
Dim foundHeader As Boolean ' Found Header Boolean
For Each ws In wb.Worksheets
' Only if the worksheet name starts with 'wsBaseName'
' and ignoring case ('TaBeLlE = Tabelle').
Set rrg = ws.Rows(HeaderRow)
For i = 0 To cUpper
cIndex = Application.Match(ColNames(i), rrg, 0)
If IsNumeric(cIndex) Then
foundHeader = True
Exit For
End If
Next i
If foundHeader Then
foundHeader = False ' reset
lRow = ws.Cells(ws.Rows.Count, cIndex).End(xlUp).Row
If lRow > 1 Then ' check if any id's
Set rg = ws.Range(ws.Cells(fRow, cIndex), _
ws.Cells(lRow, cIndex))
For Each cCell In rg.Cells
Key = CStr(cCell.Value)
If Not dict.Exists(Key) Then
n = n + 1
dict.Add Key, idBaseName & n
End If
cCell.Value = dict(Key)
Next cCell
End If
End If
Next ws
End Sub
MsgBox "Done.", vbInformation, "Change ID Part 2"
End Sub
|