Yıllar boyunca birkaç kez bunun gibi gereksinimlerim oldu, bu yüzden genel bir rutini kodladım. Bu rutinin kaynağını kaybettim ve hafızadan yeniden kodladım. Yeni sürümü test ettim ancak hatasız olduğunu kesinlikle garanti edemiyorum, bu yüzden denemeden önce verilerinizin bir kopyasını alın.
Rutin iki diziye dayanır. ColMatch , iki satırın eşleşmesi için hangi sütunların eşit olması gerektiğini söyler. ColMerge , hangi sütunların birleştirileceğini söyler. Her sütun bu dizilerden birinde belirtilmelidir.
Test verilerim için 1, 2, 3 ve 5 sütunlarında eşleşiyorum ve 4 ve 6 sütunlarını birleştiriyorum. Bunu şöyle tanımlarım:
ColMatch = Array(1, 2, 3, 5)
ColMerge = Array(4, 6)
Bu beyanları gereksinimlerinize göre değiştirmeniz gerekecektir. Sorunuz onların olması gerektiği anlamına geliyor:
ColMatch = Array(1, 3, 4)
ColMerge = Array(2)
Rutin ayrıca eklenen her değerden önce yerleştirilen sabit bir Ayırıcı kullanır . Ben vbLf olarak ayarladım, bu yüzden farklı bir satırın her değerini almak. Virgül istiyorsun, öyleyse:
Const Separator As String = ","
Değiştirmen gereken başka bir şey olduğunu sanmıyorum. Ancak, makroyu dikkatlice çalıştırmanızı öneririm. Umarım nasıl çalıştığını anlamanız için size yeterince yorum ekledim. Gerekirse sorularla geri gelin.
Sistemimde 51.800 satırın işlenmesi yaklaşık 2 dakika sürüyor, bu yüzden durum çubuğunu kaba bir ilerleme göstergesi olarak kullanıyorum.
Bu, test verilerimin başlangıç durumunu gösterir.
Bu makro çalıştırıldıktan sonra nasıl değiştiğini gösterir.
Bu yardımcı olur umarım.
Option Explicit
Sub MergeRows()
' Merges adjacent rows for which all columns listed in ColMatch are equal
' by appending the contents of the other columns from the second row to
' the first row and then deleting the second row.
Dim CheckOK As Boolean
Dim ColCrnt As Long
Dim ColLast As Long
Dim ColMatch() As Variant
Dim ColMerge() As Variant
Dim InxMatch As Long
Dim InxMerge As Long
Dim RowCrnt As Long
Dim RowLast As Long
Dim RowsMatch As Boolean
Dim TimeStart As Single
' Defines the first row to be considered for merging. This avoids
' looking at header rows (not very important) and allows a restart
' from row 600 or whatever (might be important).
Const rowDataFirst As Long = 2
' Defines the string to be placed between the value in the first row
' and the value from the second row.
Const Separator As String = vbLf
' Speeds up processing
Application.ScreenUpdating = False
' Stops the code from being interrupted by event routines
Application.EnableEvents = False
' Use status bar as a progress indicator
Application.DisplayStatusBar = True
' Record seconds since midnight at start of routine.
TimeStart = Timer
' Defines the columns which must have the same values in two
' adjacent rows for the second row to be merged into the
' first row. Column numbers must be in ascending order.
ColMatch = Array(1, 2, 3, 5)
' Defines the columns for which values from the second row
' are to be appended to the first row of a matching pair.
' Column numbers must be in ascending order. ColMatch and
' ColMerge together must specify every used column.
ColMerge = Array(4, 6)
' Replace "Merge" with the name of your worksheet
With Worksheets("Merge")
' Find last used column and last used row
ColLast = .Cells.Find("*", .Range("A1"), xlFormulas, xlWhole, _
xlByColumns, xlPrevious).Column
RowLast = .Cells.Find("*", .Range("A1"), xlFormulas, xlWhole, _
xlByRows, xlPrevious).Row
' Validate column parameters. Every column must be specified once
' in either ColMatch or ColMerge.
InxMatch = 0 ' 0 = lower bound of array
InxMerge = 0
For ColCrnt = 1 To ColLast
CheckOK = False ' Set true if check successful
If InxMatch > UBound(ColMatch) Then
' ColMatch array exhausted
Else
If ColCrnt = ColMatch(InxMatch) Then
CheckOK = True
InxMatch = InxMatch + 1
End If
End If
If Not CheckOK Then
If InxMerge > UBound(ColMerge) Then
' ColMerge array exhausted
Else
If ColCrnt = ColMerge(InxMerge) Then
CheckOK = True
InxMerge = InxMerge + 1
End If
End If
End If
If Not CheckOK Then
Call MsgBox("I was unable to find column " & ColCrnt & " in either" & _
" ColMatch or ColMerge. Please correct and try again.", _
vbOKOnly)
Exit Sub
End If
Next
RowCrnt = rowDataFirst
Do While True
If RowCrnt Mod 100 = 0 Then
' Use status bar to indicate progress
Application.StatusBar = "Row " & RowCrnt & " of " & RowLast
End If
' Attempt to match RowCrnt and RowCrnt+1
RowsMatch = True ' Assume match until find otherwise
For InxMatch = 0 To UBound(ColMatch)
ColCrnt = ColMatch(InxMatch)
If .Cells(RowCrnt, ColCrnt).Value <> _
.Cells(RowCrnt + 1, ColCrnt).Value Then
' Rows do not match
RowsMatch = False
Exit For
End If
Next
If RowsMatch Then
' Rows match. Merge second into first.
For InxMerge = 0 To UBound(ColMerge)
ColCrnt = ColMerge(InxMerge)
.Cells(RowCrnt, ColCrnt).Value = .Cells(RowCrnt, ColCrnt).Value & _
Separator & _
.Cells(RowCrnt + 1, ColCrnt).Value
Next
' Second row merged into first. Discard second row.
.Rows(RowCrnt + 1).EntireRow.Delete
' RowLast has moved up.
RowLast = RowLast - 1
' Do not step RowCrnt because there may be another match for it
If RowCrnt = RowLast Then
' All rows checked.
Exit Do
End If
Else
' Rows do not match. RowCrnt no longer of interest.
RowCrnt = RowCrnt + 1
If RowCrnt = RowLast Then
' All rows checked.
Exit Do
End If
End If
Loop
End With
' Output duration of macro to Immediate window
Debug.Print Format(Timer - TimeStart, "#,##0.00")
Application.StatusBar = False
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
databirleştirileceğini ya da nasıldatagöründüğünü söylemiyorsunuz , peki diğer C sütunları?