Comment copyr des valeurs de cellule à partir de plusieurs (mais pas de toutes) des lignes et des colonnes d'une feuille à une autre feuille

J'ai développé un outil Excel qui – après (de) sélection de plusieurs options – montre à l'user / employé le prix correct pour vendre le produit au client.

La feuille de calcul utilisée par l'user (c.-à-d. "Particulier") récupère datatables de plusieurs autres feuilles; l'une de ces feuilles est une list de prix (c'est-à-dire "Toestelprijzen Start") qui doit être mise à jour de time en time: chaque semaine, je reçois une nouvelle list de prix avec les prix des nouveaux produits que j'utilise pour mettre à jour les anciens prix dans l'outil Excel . Pour ce faire, j'utilise le code suivant qui fonctionne parfaitement:

Sub ImportPrijslijstStart() Dim sImportFile As Ssortingng, sFile As Ssortingng Dim sThisBk As Workbook Dim vfilename As Variant Application.ScreenUpdating = False Application.DisplayAlerts = False Set sThisBk = ActiveWorkbook sImportFile = Application.GetOpenFilename( _ FileFilter:="Microsoft Excel Workbooks, *.xls; *.xlsx", Title:="Open Workbook") If sImportFile = "False" Then MsgBox "No File Selected!" Exit Sub Else vfilename = Split(sImportFile, "\") sFile = vfilename(UBound(vfilename)) Application.Workbooks.Open Filename:=sImportFile Set wbBk = Workbooks(sFile) With wbBk If SheetExists("VF Start incl. BTW") Then Set wsSht = .Sheets("VF Start incl. BTW") wsSht.Copy before:=sThisBk.Sheets("Toestelprijzen Start") Else MsgBox "Er is geen sheet met de naam VF Start incl. BTW in:"&vbCr& .Name End If wbBk.Close SaveChanges:=False End With End If Application.ScreenUpdating = True Application.DisplayAlerts = True MsgBox "Prijslijst geïmporteerd" End Sub Private Function SheetExists(sWSName As Ssortingng) As Boolean Dim ws As Worksheet On Error Resume Next Set ws = Worksheets(sWSName) If Not ws Is Nothing Then SheetExists = True End Function

Chaque produit (350 articles) sur cette nouvelle list de prix importés a des prix différents selon les options sélectionnées dans la feuille de travail "Particulier". C'est-à-dire que chaque produit de cette list de prix a 31 prix différents.

Les 2 premières colonnes (A et B) affichent le numéro de produit, la 3ème colonne (C) affiche le nom du produit et la colonne D: AH affiche les prix des produits. Ensuite, les titres se situent sur la ligne 1-6 et les prix des produits commencent à la rangée 7. Ainsi, cette nouvelle feuille imscope contient des données dans les cellules A1: AH357, où les cellules D7: AH357 affichent les prix des produits.

Cependant, parfois, de nouveaux produits sont ajoutés, et les anciens sont supprimés de la nouvelle list de prix, ce qui signifie que la ligne 357 n'est pas toujours la dernière ligne. Ensuite, je veux copyr (c.-à-d. "Mise à jour") les prix de cette nouvelle feuille de calcul imscope vers la feuille de calcul avec les anciens prix.

Je copy les prix de la feuille de travail nouvelle à l'ancienne, car sur cette nouvelle list de prix, les produits qui apparaissent dans différentes colors sont affichés plusieurs fois. Chaque couleur est affichée comme un produit unique avec un numéro de produit unique, mais avec le même prix pour chaque couleur.

Cependant, je n'ai besoin que des prix de chaque produit une fois (par exemple, le produit X est livré en noir, blanc, or et rose, mais le produit X son prix est le même quelle que soit sa couleur, donc je n'ai besoin que de copyr les 31 prix dans les colonnes D : AH de 1 de ces 4 colors). Pour ce faire, j'utilise VLOOKUP pour searchr le numéro de produit unique utilisé dans la list de prix ancienne et dans la nouvelle list de prix.

Cependant, mon code ne fonctionne pas comme je le souhaite. Il ne copy qu'une seule colonne, plutôt que les 31 colonnes D: AH. En outre, il copy toutes les informations deux fois; c'est-à-dire qu'il search et trouve avec succès (copy) les valeurs (prix) dans la première colonne (D) de la nouvelle list de prix imscope à la feuille avec les anciens prix (pour actualiser les prix) de, par exemple, la ligne 7 à ligne 87 (seulement 80 lignes car il y a 80 éléments avec des numéros de produit uniques), mais, par la suite, il colmet toutes datatables (prix) une deuxième fois sur la ligne 88 à la ligne 168.

En outre, lors de l'exécution du code, il faut environ 40 secondes pour terminer. Je n'ai absolument aucun indice pourquoi mon code:

copy datatables d'une seule colonne et non de 31 colonnes
colle datatables deux fois
prend tellement de time pour finir

Je cherche de l'aide pour résoudre ces trois problèmes.

Veuillez find ci-dessous le code que j'utilise:

 Sub PrijslijstUpdatenStart() Dim Osh As Worksheet 'Sheet with the new product prices: Set Osh = ThisWorkbook.Sheets("VF Start incl. BTW") Dim Orange As Ssortingng Dim Olength As Integer Olength = Osh.Range("B1", Osh.Range("B7").End(xlDown)).Rows.Count Orange = "B7:AH" & Olength Dim Nsh As Worksheet 'Sheet on which the old prices are displayed that need to be updated with the ' new prices on "VF Start incl. BTW": Set Nsh = ThisWorkbook.Sheets("Toestelprijzen Start") Dim Nrange As Ssortingng Dim Nlength As Integer Nlength = Nsh.Range("B1", Nsh.Range("B10").End(xlDown)).Rows.Count Nrange = "B10:AG" & Nlength On Error Resume Next Dim Dept_Row As Long Dim Dept_Clm As Long Table1 = Nsh.Range(Nrange) Table2 = Osh.Range(Orange) Dept_Row = Nsh.Range("E10:AH" & Olength).Row Dept_Clm = Nsh.Range("E10:AH" & Olength).Column For Each cl In Table1 Nsh.Cells(Dept_Row, Dept_Clm) = _ Application.WorksheetFunction.VLookup(cl, Table2, 2, False) Dept_Row = Dept_Row + 1 Next cl End Sub

J'ai essayé de décrire la situation aussi clairement que possible. Si vous avez besoin de plus d'informations, faites-le moi savoir.

Ici, j'utilise un dictionary pour stocker les noms de produits sous forme de keys et de nouvelles valeurs comme arrays de la première feuille de calcul. J'ai ensuite itéré sur la deuxième feuille de calcul et, lorsqu'une correspondance est trouvée, affectez le tableau des valeurs aux colonnes adjacentes.

 Sub PrijslijstUpdatenStart() Application.ScreenUpdating = False Dim dict As Object Set dict = CreateObject("Scripting.Dictionary") With ThisWorkbook.Sheets("VF Start incl. BTW") For Each r In .Range("B7", .Range("B7").End(xlDown)) If Not dict.Exists(r.Value) Then dict.Add r.Value, r.Offset(0, 1).Resize(1, 31).Value Next End With With ThisWorkbook.Sheets("Toestelprijzen Start") For Each r In .Range("B10", .Range("B10").End(xlDown)) If dict.Exists(r.Value) Then r.Offset(0, 1).Resize(1, 31).Value = dict(r.Value) Next End With Application.ScreenUpdating = True End Sub

Mise à jour: supprimez les anciens produits manquants dans la nouvelle list de prix.

 Sub PrijslijstUpdatenStart() Application.ScreenUpdating = False Dim x As Long Dim dict As Object Set dict = CreateObject("Scripting.Dictionary") With ThisWorkbook.Sheets("VF Start incl. BTW") For Each r In .Range("B7", .Range("B7").End(xlDown)) If Not dict.Exists(r.Value) Then dict.Add r.Value, r.Offset(0, 1).Resize(1, 31).Value Next End With With ThisWorkbook.Sheets("Toestelprijzen Start") For x = .Range("B10").End(xlDown).Row To 10 Step -1 If dict.Exists(.Cells(x, "B").Value) Then .Cells(x, "C").Offset(0, 1).Resize(1, 31).Value = dict(.Cells(x, "C").Value) Else .Rows(x).Delete End If Next End With Application.ScreenUpdating = True End Sub