VBA-Code zum Zusammenführen doppelter Zeilen und Beibehalten von Nicht-Null-Werten?

Question

Ich bin auf der Suche nach einer effizienteren Möglichkeit zum Zusammenführen von doppelten Zeilen abhängig vom Spaltennamen "Produkt". Einige Zeilen haben keine Duplikate. Hier ist ein Beispiel für die Daten, mit denen ich arbeite. In Wirklichkeit arbeite ich mit Tausenden dieser Zeilen und über 40 Spalten. Wenn auf der Grundlage der Spalte "Product" festgestellt wird, dass eine doppelte Zeile vorhanden ist, besteht mein Ziel darin, in einer Zeile zusammenzuführen und die Nicht-Null-Werte beizubehalten.

Hier ist ein Link zu meinem Beitrag in mr. excel aber niemand konnte eine Lösung herauszufinden: https://www.mrexcel.com/forum/excel-questions/1014177-how-combine-rows-duplicate-info-into-one-based-column.html

Hier ist ein Bild der vor und nach dem“

image of before and after

Alle Ideen, wie ich diesen Prozess effizienter machen könnte, würde ich denken, VBA-Code? . erforderlich ist, ich zur Zeit dies zu tun manuell bin und es ist sehr schmerzhaft Danke

Answer 1

Sub compareLines() 

'Set selected cell to starting position Row 2 Column A 
ActiveSheet.Cells(2, 1).Select 

'Stopping the application updating the screen while the macro is running which can significantly increase the speed of vba 
Application.ScreenUpdating = False 

'Loop to keep macro running into it reaches the last 'Product' 
While ActiveCell.Value <> "" 

    'Check whether the product name in the next row is the same as the product in the current row  
    If ActiveCell.Value = ActiveCell.Offset(1, 0).Value Then 

     'Keep going until you reach the 40th column(change this to what u need) 
     For i = 2 To 40 

     'Checks whether the next column is blank 
     If ActiveCell.Offset(0, i).Value = "" Then 

      'If the column is in fact blank then copy the value of the row below 
      ActiveCell.Offset(0, i).Value = ActiveCell.Offset(1, i).Value 

     End If 
     'move to next column 
     Next 

    'Once the last column has been reached, delete the duplicate row 
    ActiveCell.Offset(1, 0).EntireRow.Delete 

    'If product below isn't the same as the current product 
    Else 

    'Then move to the next row 
    ActiveCell.Offset(1, 0).Select 

    End If 

Wend 

'turning this back on so you can see the changes 
Application.ScreenUpdating = True 

End Sub 

Ändern Sie die ‚für‘ Anweisung, wie viele Spalten Sie :)

Answer 2

so etwas wie dies auch sein mag:

dim rRange as Range 
Set rRange = Application.InputBox('', '' , Type:=8) 

Dies funktioniert für mich, nicht genau

Erinnerst ..