Comparez deux feuilles puis les différences de sortie – SEMI COMPLÉTÉ

En alternative à la solution postée par Thomas, vous pouvez utiliser des dictionarys pour stocker des index pour chaque ID unique et les colonnes pertinentes. Par la population des dictionarys dans les loops basées sur les arrays codés (vHeader et vLookFor) et la méthode range.find, cela vous permet de modifier la position des colonnes et, dans une certaine mesure, le comportement du code sans devoir s'inquiéter des index plus bas.

Le script remplit d'abord les dictionarys pour l'en-tête et les ID pour les feuilles nouvelles et anciennes, puis boucle les nouvelles keys ID pour find ceux qui ont changé l'un des champs définis comme étant pertinents dans vLookFor et ceux qui sont tout neuf.

L'utilisation de la colonne de fonctionLigne dans la création de la gamme d'en-têtes shtChange garantit que si vous ajoutez un champ au vheader, il sera automatiquement ajouté à shtChange.Pour éviter d'avoir à supprimer le shtChange au cas où vous voulez réexécuter la macro, je J'ai ajouté une fonction doExist: il supprime simplement la feuille et renvoie un nouvel object de feuille de calcul portant le même nom.

Dans le cas où une différence, ou un nouveau champ est identifié, la ligne est déplacée vers le shtChange et la différence calculée (Nouveau prix / Ancien prix en%).

En modifiant l'ordre des colonnes, au moment de l'épandage, vous verrez le champ par champ pour toutes les 120 colonnes, mais vous pouvez mettre à jour cela pour utiliser un dictionary, ou plus spécifiquement la gamme.définir, atténuer le genre de choses que les users ont tendance à faire (colonnes en mouvement, sorting, etc.) – mais vous en plaidrez.

 Sub Compare() 'reference to Microsoft scripting runtime is a prerequirejsite for Dictionaries to work 'can the shtOld.usedrange.columns.count potentially substitute this hardcode? Const ID_COL As Integer = 1 'ID is in this column Const NUM_COLS As Integer = 120 'how many columns are being compared Dim shtNew As Worksheet, shtOld As Worksheet, shtChange As Worksheet Dim vHeader As Variant Dim vLookFor As Variant Dim vElement As Variant Dim vKeyID As Variant Dim vKeyValueIdx As Variant Dim oldRowIdx As Variant Dim oldColIdx As Variant Dim newRowIdx As Variant Dim newColIdx As Variant Dim chgRowIdx As Long Dim oldPriceIdx As Long Dim newPriceIdx As Long Dim diffPriceIdx As Long Dim chgTypeIdx As Long Dim shtChangeName As Ssortingng Dim oldIndexDict As Dictionary Dim oldIdRowDict As Dictionary Dim newIndexDict As Dictionary Dim newIdRowDict As Dictionary Dim chgIndexDict As Dictionary Dim i As Long, j As Long, k As Long, m As Long, n As Long Dim x As Integer, Id Dim valOld, valNew 'some intital parameters shtChangeName = "Change Report" 'rather than printing the header one value at a time, then you can simply place an array directly into the range vHeader = Array("Change Type", "ID", "Name", "Product", "Old Price", "New Price", "Difference") 'we create a array for the headers that we will be looking for, for the shtChange vLookFor = Array("ID", "Name", "Product", "Price") 'setting the worksheet object Set shtNew = ThisWorkbook.Sheets("Sheet1") Set shtOld = ThisWorkbook.Sheets("Sheet2") 'add the shtChange Set shtChange = doExist(shtChangeName) 'I really hate having to manually delete a worksheets in case I want to rerun, so I added the doExist function to delete the sheet if it allready exist 'disable any data fitler shtNew.AutoFilterMode = False shtOld.AutoFilterMode = False 'Generating the bold headers for the change sheet, to avoid retyping the range over and over again, we use with With shtChange.Range("A1:" & ColumnLetter(UBound(vHeader) + 1) & "1") 'this is implicitly repeated for all rows, eg '.value' -> 'shtChange.Range("A1:G1").value' .Value = vHeader .Font.Bold = True End With 'I will be using dictionaries to find my way around the position of specific headers and ID's. This I do for added robustness, in case the business decides to move columns, change the sorting etc. in only the old or new sheet Set oldIndexDict = CreateObject("Scripting.Dictionary") 'for header index Set oldIdRowDict = CreateObject("Scripting.Dictionary") 'for ID row index Set newIndexDict = CreateObject("Scripting.Dictionary") 'for header index Set newIdRowDict = CreateObject("Scripting.Dictionary") 'for ID row index Set chgIndexDict = CreateObject("Scripting.Dictionary") 'for header index 'we populate the index dictionaries For Each vElement In vLookFor If Not newIndexDict.Exists(CStr(vElement)) Then oldIndexDict.Add CStr(vElement), shtOld.Range("1:1").Find(what:=CStr(vElement), LookIn:=xlValues, LookAt:=xlWhole).Column newIndexDict.Add CStr(vElement), shtNew.Range("1:1").Find(what:=CStr(vElement), LookIn:=xlValues, LookAt:=xlWhole).Column On Error Resume Next chgIndexDict.Add CStr(vElement), shtChange.Range("1:1").Find(what:=CStr(vElement), LookIn:=xlValues, LookAt:=xlWhole).Column On Error GoTo 0 End If Next 'In case the data is not ordered exactly the same in the new and old sheets, we populate the IdRow dictionaries to enable us to find the position of a specific ID in either sheet 'first the oldSht For i = 2 To shtOld.UsedRange.Rows.Count 'be aware that if your data does not start on row 1, the usedrange will not accurately reflect the true last row number If Not oldIdRowDict.Exists(CStr(shtOld.Cells(i, oldIndexDict("ID")))) And CStr(shtOld.Cells(i, oldIndexDict("ID"))) <> "" Then oldIdRowDict.Add CStr(shtOld.Cells(i, oldIndexDict("ID"))), i End If Next 'then the newSht For j = 2 To shtNew.UsedRange.Rows.Count 'be aware that if your data does not start on row 1, the usedrange will not accurately reflect the true last row number If Not newIdRowDict.Exists(CStr(shtNew.Cells(j, newIndexDict("ID")))) And CStr(shtNew.Cells(j, newIndexDict("ID"))) <> "" Then newIdRowDict.Add CStr(shtNew.Cells(j, newIndexDict("ID"))), j End If Next 'get indexes for fields specific for shtChange chgTypeIdx = shtChange.Range("1:1").Find(what:="Change Type", LookIn:=xlValues, LookAt:=xlWhole).Column 'index for changetype oldPriceIdx = shtChange.Range("1:1").Find(what:="Old Price", LookIn:=xlValues, LookAt:=xlWhole).Column 'index for old price newPriceIdx = shtChange.Range("1:1").Find(what:="New Price", LookIn:=xlValues, LookAt:=xlWhole).Column 'indexd for new price diffPriceIdx = shtChange.Range("1:1").Find(what:="Difference", LookIn:=xlValues, LookAt:=xlWhole).Column 'index for difference column 'then we loop the keys in the New sheet and make the relevant comparision, incl. move to shtChange For Each vKeyID In newIdRowDict.Keys 'resortingeve the relevant indexes for the columns going into the shtChange newRowIdx = newIdRowDict(vKeyID) If oldIdRowDict.Exists(vKeyID) Then oldRowIdx = oldIdRowDict(vKeyID) For Each vKeyValueIdx In newIndexDict.Keys If shtOld.Cells(oldRowIdx, oldIndexDict(vKeyValueIdx)) <> shtNew.Cells(newRowIdx, newIndexDict(vKeyValueIdx)) Then chgRowIdx = shtChange.UsedRange.Rows.Count + 1 shtChange.Cells(chgRowIdx, chgTypeIdx) = "Update" 'the key allready existed in the old sheet, so update For m = LBound(vLookFor) To UBound(vLookFor) If chgIndexDict.Exists(vLookFor(m)) Then shtChange.Cells(chgRowIdx, chgIndexDict(vLookFor(m))) = shtNew.Cells(newRowIdx, newIndexDict(vLookFor(m))) End If Next shtChange.Cells(chgRowIdx, oldPriceIdx) = shtOld.Cells(oldRowIdx, oldIndexDict("Price")) shtChange.Cells(chgRowIdx, newPriceIdx) = shtNew.Cells(newRowIdx, newIndexDict("Price")) shtChange.Cells(chgRowIdx, diffPriceIdx) = shtChange.Cells(chgRowIdx, newPriceIdx) / shtChange.Cells(chgRowIdx, oldPriceIdx) End If Next shtChange.Columns(diffPriceIdx).NumberFormat = "0.0%" 'This is subject to risk of moved columns etc., but to retain functionality of the postd code we loop all columns the respective ID, and set the colors For k = 1 To NUM_COLS If shtOld.Cells(oldRowIdx, k).Value <> shtNew.Cells(newRowIdx, k).Value Then shtNew.Cells(newRowIdx, k).Interior.Color = vbYellow Else shtNew.Cells(newRowIdx, k).Interior.ColorIndex = xlNone End If Next Else 'it is a new entry shtNew.Range("A" & newRowIdx).EntireRow.Interior.Color = vbGreen 'new entry chgRowIdx = shtChange.UsedRange.Rows.Count + 1 For n = LBound(vLookFor) To UBound(vLookFor) 'loops the elements of the search fields, and if they exist in shtChange, we fetch the value from shtNew If chgIndexDict.Exists(vLookFor(n)) Then shtChange.Cells(chgRowIdx, chgIndexDict(vLookFor(n))) = shtNew.Cells(newRowIdx, newIndexDict(vLookFor(n))) End If Next shtChange.Cells(chgRowIdx, chgTypeIdx) = "New" 'key is new, so New shtChange.Cells(chgRowIdx, newPriceIdx) = shtNew.Cells(newRowIdx, newIndexDict("Price")) 'since the element is new, only the new price is relevant for shtChange End If Next shtChange.Range("A1:G1").Columns.AutoFit shtChange.Range("A1").AutoFilter 'set the dicts to nothing Set oldIndexDict = Nothing Set oldIdRowDict = Nothing Set newIndexDict = Nothing Set newIdRowDict = Nothing Set chgIndexDict = Nothing MsgBox ("Complete") End Sub Function doExist(strSheetName) As Worksheet Dim wb As Workbook: Set wb = ThisWorkbook Dim wsTest As Worksheet Dim nWs As Worksheet Set wsTest = Nothing On Error Resume Next Set wsTest = wb.Worksheets(strSheetName) On Error GoTo 0 If Not wsTest Is Nothing Then Application.DisplayAlerts = False wsTest.Delete Application.DisplayAlerts = True End If Set doExist = wb.Worksheets.Add(after:=wb.Sheets(wb.Sheets.Count)) doExist.Name = strSheetName End Function Function ColumnLetter(ColumnNumber As Long) As Ssortingng Dim n As Long Dim c As Byte Dim s As Ssortingng n = ColumnNumber Do c = ((n - 1) Mod 26) s = Chr(c + 65) & s n = (n - c) \ 26 Loop While n > 0 ColumnLetter = s End Function 

Vous devrez définir une reference à Microsoft Scripting Runtime.

Cela devrait être très proche de ce que vous voulez.

• ProductRecord: stocke toute la variable à écrire dans la nouvelle feuille de calcul
• dProducts: est un dictionary qui détient les loggings du produit
• Iterate Sheet1 ajoutant des produits à dProducts par ID si les cellules sont colorées
• Iterate Sheet2 recherchant dProducts par ID. Si nous trouvons, nous établissons le prix ancien du produit
• Iterate Worksheet ("Change Report") Collant les produits dans dProducts au fur et à mesure

Enregistrement du produit de class

 Option Explicit Public ChangeType As Ssortingng Public ID As Ssortingng Public Name As Ssortingng Public Product As Ssortingng Public OldPrice As Double Public NewPrice As Double Public Difference As Double Public Color As Long Public Sub Paste(Destination As Range) Dim arData(5) Difference = NewPrice - OldPrice If Color = vbGreen Then ChangeType = "New Product" Else ChangeType = "ID Change" arData(0) = ChangeType arData(1) = Name arData(2) = Product arData(3) = OldPrice arData(4) = NewPrice arData(5) = Difference Destination.Resize(1, 6) = arData 'WorksheetFunction.Transpose(arData) Destination.Interior.Color = Color End Sub 

Le rest de l'histoire

Option Explicit

 Sub Compare() ToggleEvents False Dim shtNew As Excel.Worksheet, shtOld As Excel.Worksheet, shtChange As Excel.Worksheet Dim rwNew As Range Dim k As Ssortingng Dim lastRow As Long, x As Long, y Dim Product As ProductRecord Dim dProducts As Dictionary Set dProducts = New Dictionary Set shtNew = Sheets("Sheet1") Set shtOld = Sheets("Sheet2") shtNew.AutoFilterMode = False shtOld.AutoFilterMode = False With shtNew lastRow = .Range("A" & Rows.Count).End(xlUp).Row For x = 2 To lastRow For Each y In Array(1, 11, 12, 14) If .Cells(x, y).Interior.color = vbYellow Or .Cells(x, y).Interior.color = vbGreen Then Set Product = New ProductRecord k = .Cells(x, 1).Value Product.color = .Cells(x, y).Interior.color Product.ID = .Cells(x, 1).Value 'ID Product.Name = .Cells(x, 11).Value 'Name Product.Product = .Cells(x, 12).Value 'Product Product.NewPrice = .Cells(x, 14).Value 'Price old If Not dProducts.Exists(k) Then dProducts.Add k, Product Exit For End If End If Next Next End With If dProducts.Count > 0 Then With shtOld lastRow = .Range("A" & Rows.Count).End(xlUp).Row For x = 2 To lastRow k = .Cells(x, 1).Value If dProducts.Exists(k) Then dProducts(k).OldPrice = .Cells(x, 14).Value 'ID End If Next End With End If Set shtChange = getChangeReportWorkSheet With shtChange.Range("A1:G1") .Value = Array("Change Type", "ID", "Name", "Product", "Old", "New", "Difference") Selection.Font.Bold = True End With With shtChange lastRow = dProducts.Count - 1 For x = 0 To lastRow dProducts.Items(x).Paste .Cells(x + 2, 1) Next .Range("A1:G1").EntireColumn.AutoFit End With ToggleEvents True 'Selection.AutoFilter MsgBox ("Complete") End Sub Sub ToggleEvents(EnableEvents As Boolean) With Application .EnableEvents = EnableEvents .Calculation = IIf(EnableEvents, xlCalculationAutomatic, xlCalculationManual) End With End Sub Function getChangeReportWorkSheet() As Worksheet Application.DisplayAlerts = False On Error Resume Next Worksheets("Change Report").Delete On Error GoTo 0 Application.DisplayAlerts = True Set getChangeReportWorkSheet = Sheets.Add(After:=Sheets(Sheets.Count)) getChangeReportWorkSheet.Name = "Change Report" End Function