Astuces Excel
  1. Astuces Excel
  3. VBA (Excel): copy en boucle sur plusieurs critères dans plusieurs feuilles de travail
Intereting Posts
Utilisation d'Excel VBA pour exécuter une requête SQL Fonction d'insertion VBA dans la barre de formule Importation SSIS Excel to SQL – Les premières 6 lignes du file contiennent des informations liées à l'en-tête Garder les zéros principaux avec find et replace Données d'input reçues d'un courrier électronique dans un file CSV / Excel / LibreOffic Calc VB: Sélectionnez chaque 6ème cellule dans une colonne et insérez à droite Fonction SUM de Excel 2010 ne reconnaissant pas le nombre négatif référencé à une autre feuille Comment download un file à partir d'un projet ou d'un location spécifique à l'aide de nodejs? Un moyen propre à convertir une tableur avec de nombreuses lignes en pdf Pourquoi mon index est-il hors de scope dans vba? Afficher datatables de datagridview vers reportviewer C # Afficher chaque feuille dans une boucle continue Macro pour aller à une feuille de calcul Comment faire une table dans Excel en fonction d'un file text? Copier automatiquement et coller des colonnes spécifiques en fonction de la valeur ComboBox

VBA (Excel): copy en boucle sur plusieurs critères dans plusieurs feuilles de travail

Context
J'ai un file maître qui contient de nombreuses feuilles de données, et j'ai une list des changements demandés, mis à jour en permanence. J'ai besoin d'écrire une macro de sorte qu'elle déroulera chaque ligne dans la feuille de modifications et finda sa contrepartie dans les fiches de données réelles. J'ai besoin de copyr les cellules concernées de la feuille de modification à la ligne respective où elle existe dans sa feuille particulière.

Information

  • Chaque observation a un identifiant général dans la colonne A ( LOBID )
  • A également un identifiant spécifique dans la colonne E ( CourseCode )

  • Chaque paire est unique, car chaque CourseCode peut exister à l'intérieur de plusieurs feuilles sous plusieurs LOBID s mais ne correspondra qu'avec une LOBID une fois. 

     Sub InputChanges() Dim changeWS As Worksheet: Dim destWS As Worksheet Dim rngFound As Range: Dim strFirst As Ssortingng Dim LOBID As Ssortingng: Dim CourseCode As Ssortingng Dim i As Integer: Dim LastRow As Integer Const SHEET_NAMES As Ssortingng = "Sheet A, Sheet B, Sheet C, etc." Set changeWS = Sheets("Changes") Application.DisplayAlerts = False Application.ScreenUpdating = False For Each destWS In ActiveWorkbook.Worksheets If InStr(1, SHEET_NAMES, destWS.Name, vbBinaryCompare) > 0 Then For i = 4 To changeWS.Range("A" & Rows.Count).End(xlUp).Row LOBID = changeWS.Cells(i, 2) CourseCode = changeWS.Cells(i, 5) Set rngFound = Columns("A").Find(LOBID, Cells(Rows.Count, "A"), xlValues, xlWhole) If Not rngFound Is Nothing Then strFirst = rngFound.Address Do If Cells(rngFound.Row, "E").Value = CourseCode Then Cells(rngFound.Row, "AP").Value = changeWS.Cells(i, 24).Value End If Set rngFound = Columns("A").Find(LOBID, rngFound, xlValues, xlWhole) Loop While rngFound.Address <> strFirst End If Next i End If Next Set rngFound = Nothing Application.DisplayAlerts = True Application.ScreenUpdating = True End Sub

Voici ma tentative jusqu'à présent, j'ai l'printing que c'est plutôt éloquent, mais j'espère que la logique est logique. Je tente de parcourir chaque ligne dans la feuille de modifications, searchz toutes les feuilles (A, B, C, … L) pour LOBID, puis pour CourseCode. Lorsqu'une paire correspondante est trouvée, j'espère copyr la valeur du changeWS vers la cellule appariée dans la fiche technique (il y a beaucoup de valeurs à copyr, mais je les ai laissées pour la brièveté du code). Il ne jette pas d'erreurs, mais il ne semble rien faire du tout. Si quelqu'un pouvait au less me pousser dans la bonne direction, je l'apprécierais.

Compilé mais pas testé: 

 Sub InputChanges() Dim changeWS As Worksheet, rw As Range Dim i As Integer Set changeWS = ActiveWorkbook.Sheets("Changes") Application.DisplayAlerts = False Application.ScreenUpdating = False For i = 4 To changeWS.Range("A" & Rows.Count).End(xlUp).Row Set rw = GetRowMatch(CStr(changeWS.Cells(i, 2)), CStr(changeWS.Cells(i, 5))) If Not rw Is Nothing Then rw.Cells(1, "AP").Value = changeWS.Cells(i, 24).Value changeWS.Cells(i, 2).Interior.Color = vbGreen Else changeWS.Cells(i, 2).Interior.Color = vbRed End If Next i Application.DisplayAlerts = True Application.ScreenUpdating = True End Sub Function GetRowMatch(LOBID As Ssortingng, CourseCode As Ssortingng) As Range Dim arrSheets, s, sht As Worksheet, rv As Range, f As Range Dim addr1 As Ssortingng arrSheets = Array("Sheet A", "Sheet B", "Sheet C") ', etc.") For Each s In arrSheets Set s = ActiveWorkbook.Sheets(s) Set f = s.Columns(1).Find(LOBID, Cells(Rows.Count, "A"), xlValues, xlWhole) If Not f Is Nothing Then addr1 = f.Address() Do If f.EntireRow.Cells(5) = CourseCode Then Set GetRowMatch = f.EntireRow 'return the entire row Exit Function End If Set f = s.Columns(1).Find(LOBID, f, xlValues, xlWhole) Loop While f.Address() <> addr1 End If Next s 'got here with no match - return nothing Set GetRowMatch = Nothing End Function