Vorhandene Codes umstellen

[Agguchen]

Oh das wäre so toll. Vielen Dank

[cysu11]

Die Mappingdaten stehen beide in Spalte A? oder ist z.b. die 11111111 in Spalte A und 22222222 in Spalte B?

[Agguchen]

Die Mappingdaten stehen im Tabellenblatt "Mapping" und die Daten die gemappt werden sollen stehen in Tabellenblatt Tabelle 1 und Spalte 11

[cysu11]

Ja, aber die Mappingdaten in Tabelle Mapping sind in deiner Datei beide in Spalte A?
Z.B. in A1 steht 11111111 22222222?

[Agguchen]

Spalte A alte StellenID, Spalte B neue StellenID

[cysu11]

Hallo Vanesa,

siehe Anhang ich hoffe das passt so. :)

LG, Alexandra

[snb]

Code:

Sub M_snb()
  Tabelle1.ListObjects(1).Range.Sort Tabelle1.Cells(1, 11), , , , , , , 1
  sn = Tabelle1.ListObjects(1).Range
 
  With CreateObject("scripting.dictionary")
  For j = 1 To UBound(sn)
    .Item(.Count) = Application.Index(sn, j)
 
      If j > 1 And j < UBound(sn) Then
      For jj = 1 To Left(sn(j + 1, 11), 1) - Left(sn(j, 11), 1) - 1
        .Item(.Count) = Application.Index(sn, j)
      Next
      End If
  Next
      Tabelle1.Cells(10, 1).Resize(.Count, UBound(sn, 2)) = Application.Index(.items, 0, 0)
  End With
End Sub

Aber.... Ich glaube nicht das Spalte K die Werte 111, 222, 333 usw. enthält.
Es wäre besser uns das Ziel dieser Vorgehensweise zu verraten.

[Egon12]

Hallo,

mal noch eine andere Vorgehensweise.

Code:

Option Explicit
Sub NeueIDMappen()
    Dim objDic As Object, Zelle As Range, arrID, tmp(), arrZeile(), i&, j&, k&, r&, iID&, iZ&
    Set objDic = CreateObject("Scripting.Dictionary")
    For Each Zelle In Tabelle1.Range("Tabelle1[Spalte11]")
        objDic(Zelle) = 0
    Next
    arrID = objDic.keys
    Application.ScreenUpdating = False
    With Tabelle2
        For i = UBound(arrID) To LBound(arrID) Step -1
            iID = arrID(i).Row
            tmp = Tabelle1.ListObjects(1).DataBodyRange.Rows(iID - 1).Value
            iZ = WorksheetFunction.CountIf(Tabelle2.Columns(1), arrID(i))
            If iZ > 0 Then
                ReDim arrZeile(1 To iZ, 1 To 17)
                For j = 1 To .UsedRange.Count
                    If arrID(i) = .Cells(j, 1) Then
                        r = r + 1
                        For k = 1 To 17
                            If k <> 11 Then arrZeile(r, k) = tmp(1, k)
                            If k = 11 Then arrZeile(r, k) = .Cells(j, 2)
                        Next k
                    End If
                Next j
                With Tabelle1.ListObjects(1).DataBodyRange
                    .Rows(iID & ":" & iID + iZ - 1).Insert
                    .Cells(iID, 1).Resize(iZ, 17) = arrZeile
                End With
            End If
            iZ = 0
            r = 0
        Next i
    End With
    Tabelle2.UsedRange.ClearContents
End Sub

Verarbeitet wird via Array und geschrieben wird blockweise. So sollte es um ein Vielfaches schneller sein.

Gruß Uwe

[Agguchen]

Guten Morgen zusammen,

erstmal lieben Dank Alexandra, es passt soweit.

@Uwe, wo kann ich das noch einbauen?

Ich hätte auch noch zwei Erweiterungen:

1. Die neuen kopierten Zeilen sollen als Beginndatum (Spalte 16) bspw. 01.06.2025 bekommen
2. Die alten Zeilen die kopiert wurden, als Endedatum (Spalte 17) bspw. 22.02.2222

Ist das möglich?

Und kann man den Button "umstellen" woanders platzieren?

[Egon12]

Hallo,
Diese Prozedur kannst du in ein allgemeines Modul packen. Die Verarbeitung erfolgt über die Modulnamen der Tabellenblätter, also nicht den Namen des "Kartenreiters". Lade die Datei runter, welche ich hochgeladen hatte, da findet sich alles wieder. Ich habe der einfachen Verarbeitbakeit wegen die ID Kombis auf 2 Spalten aufgeteilt.

Das Anpassen der geänderten Spalten sollte kein Problem sein, da das meiste eh automatisch erkannt wird. Lade dazu einfach noch mal nun aktuellen Tabellenaufbau hoch.
Das hatte ich falsch verstanden.


Gruß Uwe

---

Hallo,

anbei die gewünschten Sachen eingebaut. Der Button ist jetzt im Ribbon Tab "Eigene Aktionen"

Gruß Uwe