[英]Combining consecutive values in a column with the help of VBA
我有這樣的數據:
A049
A050
A051
A053
A054
A055
A056
A062
A064
A065
A066
我想要這樣的輸出:
如您所見,我想要連續順序的范圍
我正在嘗試這樣的事情:
Private Sub CommandButton1_Click()
Set wb = ThisWorkbook
lastRow = wb.Sheets("Sheet1").Range("A" & wb.Sheets("Sheet1").Rows.Count).End(xlUp).Row
For i = 2 To lastRow
r = wb.Sheets("Sheet1").Range("A" & i).Value
If wb.Sheets("Sheet1").Range("A" & i).Value = wb.Sheets("Sheet1").Range("A" & i+1).Value
Next i
End Sub
但不幫我
試試下面的代碼
Private Sub CommandButton1_Click()
Set wb = ThisWorkbook
lastRow = wb.Sheets("Sheet1").Range("A" & wb.Sheets("Sheet1").Rows.Count).End(xlUp).Row
Dim lastNum, Binsert As Integer
Dim firstCell, lastCell, currentCell As String
Binsert = 1
lastNum = getNum(wb.Sheets("Sheet1").Range("A1").Value)
firstCell = wb.Sheets("Sheet1").Range("A1").Value
For i = 2 To lastRow
activeNum = getNum(wb.Sheets("Sheet1").Range("A" & i).Value)
currentCell = wb.Sheets("Sheet1").Range("A" & i).Value
If (activeNum - lastNum) = 1 Then
'nothing
Else
lastCell = wb.Sheets("Sheet1").Range("A" & (i - 1)).Value
wb.Sheets("Sheet1").Range("B" & Binsert).FormulaR1C1() = firstCell
If (firstCell <> lastCell) Then
wb.Sheets("Sheet1").Range("C" & Binsert).FormulaR1C1() = lastCell
End If
Binsert = Binsert + 1
firstCell = wb.Sheets("Sheet1").Range("A" & i).Value
End If
lastNum = activeNum
Next i
'last entry
wb.Sheets("Sheet1").Range("B" & Binsert).FormulaR1C1() = firstCell
If (firstCell <> currentCell) Then
wb.Sheets("Sheet1").Range("C" & Binsert).FormulaR1C1() = currentCell
End If
End Sub
Public Function getNum(ByVal num As String) As Integer
getNum = Val(Mid(num, 2))
End Function
我感覺很慈善,所以嘗試了一些應該可以工作的代碼。 它假設您的起始值在 A1 中,並將結果放在 C1 中。
Sub x()
Dim v1, v2(), i As Long, j As Long
v1 = Range("A1", Range("A" & Rows.Count).End(xlUp)).Value
ReDim v2(1 To UBound(v1, 1), 1 To 2)
For i = LBound(v1, 1) To UBound(v1, 1)
j = j + 1
v2(j, 1) = v1(i, 1)
If i <> UBound(v1, 1) Then
Do While Val(Right(v1(i + 1, 1), 3)) = Val(Right(v1(i, 1), 3)) + 1
i = i + 1
If i = UBound(v1, 1) Then
v2(j, 2) = v1(i, 1)
Exit Do
End If
Loop
End If
If v1(i, 1) <> v2(j, 1) Then v2(j, 2) = v1(i, 1)
Next i
Range("C1").Resize(j, 2) = v2
End Sub
另一種解決方案。 它從最后一行向后循環到第一行。
Option Explicit
Public Sub FindConsecutiveValues()
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Sheet1")
Dim lRow As Long 'find last row
lRow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
Dim lVal As String 'remember last value (stop value)
lVal = ws.Range("A" & lRow).Value
Const fRow As Long = 2 'define first data row
Dim i As Long
For i = lRow To fRow Step -1 'loop from last row to first row backwards
Dim iVal As Long
iVal = Val(Right(ws.Range("A" & i).Value, Len(ws.Range("A" & i).Value) - 1)) 'get value of row i without A so we can calculate
Dim bVal As Long
bVal = 0 'reset value
If i <> fRow Then 'if we are on the first row there is no value before
bVal = Val(Right(ws.Range("A" & i - 1).Value, Len(ws.Range("A" & i - 1).Value) - 1)) 'get value of row i-1 without A
End If
If iVal - 1 = bVal Then
ws.Rows(i).Delete 'delete current row
Else
If lVal <> ws.Range("A" & i).Value Then 'if start and stop value are not the same …
ws.Range("B" & i).Value = lVal 'write stop value in column B
End If
lVal = ws.Range("A" & i - 1).Value 'remember now stop value
End If
Next i
End Sub
聲明:本站的技術帖子網頁,遵循CC BY-SA 4.0協議,如果您需要轉載,請注明本站網址或者原文地址。任何問題請咨詢:yoyou2525@163.com.