comment ajuster le code pour une meilleure performance

Question

Je suis en train de faire rapport de bord de fichier Excel qui sont organisés en rangées,

A, B, C,

D, E

le but est à créer des relations de chaque ligne:

A, B

A, C

B, C

I ont les codes suivants, le problème est le code est efficace lorsque les lignes sont de longueur égale, mais par exemple pour les lignes qui précèdent, il créent également des bords suivante (relation):

D « ,"

E ""

qui créent gros problème pour les grands ensembles de données. Je me demandais si un corps peut m'aider à ajuster le code de la façon de créer la liste des arêtes seulement jusqu'aux cellules remplies dans chaque rangée. S'il y a un autre moyen de le faire, plus efficace l'appréciera.

Merci beaucoup, Sera une aide précieuse.

Mon code:

Sub Transform() 

Dim targetRowNumber As Long 
targetRowNumber = Selection.Rows(Selection.Rows.Count).Row + 2 

Dim col1 As Variant 
Dim cell As Range 
Dim colCounter As Long 
Dim colCounter2 As Long 

Dim sourceRow As Range: For Each sourceRow In Selection.Rows 

    For colCounter = 1 To Selection.Columns.Count - 1 


     col1 = sourceRow.Cells(colCounter).Value 
     For colCounter2 = colCounter + 1 To Selection.Columns.Count 
      Set cell = sourceRow.Cells(, colCounter2) 

      If Not cell.Column = Selection.Column Then 
       Selection.Worksheet.Cells(targetRowNumber, 1) = col1 
       Selection.Worksheet.Cells(targetRowNumber, 2) = cell.Value 
       targetRowNumber = targetRowNumber + 1 
      End If 

     Next colCounter2 

    Next colCounter 

Next sourceRow 

End Sub 

Answer 1

J'ai joué avec elle - ce qui devrait faire l'affaire. Nous pouvons probablement accélérer en sortie vers un autre tableau de variante si nécessaire, mais cela m'a couru assez rapidement pour:

Sub Transform_New() 

Dim rngSource As Range, rngDest As Range 
Dim varArray As Variant 
Dim i As Integer, j As Integer, k As Integer 

Set rngSource = Sheet1.Range("A1", Sheet1.Cells(WorksheetFunction.CountA(Sheet1.Columns(1)), 1)) 'Put all used rows into range 
Set rngDest = Sheet1.Cells(WorksheetFunction.CountA(Sheet1.Columns(1)), 1).Offset(2, 0) 'Set target range to start 2 below source range 

varArray = Range(rngSource, rngSource.Offset(0, Range("A1").SpecialCells(xlCellTypeLastCell).Column)).Value 

For i = LBound(varArray, 1) To UBound(varArray, 1) 'Loop vertically through array 
    For j = LBound(varArray, 2) To UBound(varArray, 2) 'Loop horizontally through each line apart from last cell 
     k = j 
     Do Until varArray(i, k) = "" 
       k = k + 1 
       If varArray(i, k) <> "" Then 
        rngDest.Value = varArray(i, j) 
        rngDest.Offset(0, 1).Value = varArray(i, k) 
        Set rngDest = rngDest.Offset(1, 0) 
       End If 
     Loop 
    Next 
Next 

End Sub