Bu VBA veya sayfanızda çalıştırabileceğiniz bir makro. Sen vurmak zorundadır alt+ F11istemi Uygulama için Visual Basic getirmek için, çalışma kitabınızda gidip right click - insert - moduleorada bu kodu yapıştırın. Ardından düğmesine basarak modülü VBA içinden çalıştırabilirsiniz F5. Bu makronun adı "test"
Sub test()
'define variables
Dim RowNum as long, LastRow As long
'turn off screen updating
Application.ScreenUpdating = False
'start below titles and make full selection of data
RowNum = 2
LastRow = Cells.SpecialCells(xlCellTypeLastCell).Row
Range("A2", Cells(LastRow, 4)).Select
'For loop for all rows in selection with cells
For Each Row In Selection
With Cells
'if customer name matches
If Cells(RowNum, 1) = Cells(RowNum + 1, 1) Then
'and if customer year matches
If Cells(RowNum, 4) = Cells(RowNum + 1, 4) Then
'move attribute 2 up next to attribute 1 and delete empty line
Cells(RowNum + 1, 3).Copy Destination:=Cells(RowNum, 3)
Rows(RowNum + 1).EntireRow.Delete
End If
End If
End With
'increase rownum for next test
RowNum = RowNum + 1
Next Row
'turn on screen updating
Application.ScreenUpdating = True
End Sub
Bu, sıralanmış bir e-tablo üzerinden çalışır ve hem müşteriyle hem de yılla eşleşen ardışık satırları birleştirir ve şimdi boş satırı siler. Elektronik tablo, sunduğunuz şekilde, müşteriler ve artan yıllar şeklinde sıralanmalıdır; bu belirli makro, ardışık satırların ötesine bakmaz .
Edit - with statementtamamen gereksiz benim tamamen mümkündür , ama kimseye zarar vermiyor ..
REVİZİT 02/28/14
Birisi bu cevabı başka bir soruda kullandı ve geri döndüğümde bu VBA'nın fakir olduğunu düşündüm. Yeniden yaptım -
Sub CombineRowsRevisited()
Dim c As Range
Dim i As Integer
For Each c In Range("A2", Cells(Cells.SpecialCells(xlCellTypeLastCell).Row, 1))
If c = c.Offset(1) And c.Offset(,4) = c.Offset(1,4) Then
c.Offset(,3) = c.Offset(1,3)
c.Offset(1).EntireRow.Delete
End If
Next
End Sub
Revisited 05/04/16
Tekrar soruldu Birden çok satırdaki değerleri tek bir satıra nasıl birleştirebilirim? Bir modül var, ama açıklayan değişkenlere ihtiyaç var ve yine oldukça zayıf.
Sub CombineRowsRevisitedAgain()
Dim myCell As Range
Dim lastRow As Long
lastRow = Cells(Rows.Count, "A").End(xlUp).Row
For Each myCell In Range(Cells("A2"), Cells(lastRow, 1))
If (myCell = myCell.Offset(1)) And (myCell.Offset(0, 4) = myCell.Offset(1, 4)) Then
myCell.Offset(0, 3) = myCell.Offset(1, 3)
myCell.Offset(1).EntireRow.Delete
End If
Next
End Sub
Bununla birlikte, soruna bağlı olarak, step -1hiçbir satır atlanmaması için bir satır numarasında daha iyi olabilir .
Sub CombineRowsRevisitedStep()
Dim currentRow As Long
Dim lastRow As Long
lastRow = Cells(Rows.Count, 1).End(xlUp).Row
For currentRow = lastRow To 2 Step -1
If Cells(currentRow, 1) = Cells(currentRow - 1, 1) And _
Cells(currentRow, 4) = Cells(currentRow - 1, 4) Then
Cells(currentRow - 1, 3) = Cells(currentRow, 3)
Rows(currentRow).EntireRow.Delete
End If
Next
End Sub
