Как выровнять значения столбцов с их совпадающими значениями в другом столбце?
У меня есть несколько столбцов данных, которые мне нужно выровнять по основному столбцу.
Ниже приведен пример того, чего я надеюсь достичь, но с таблицей, содержащей более крупные строки и больше строк. Данные в каждой строке уникальны, появляются только один раз. Поэтому я просто стремлюсь выровнять эти уникальные значения в столбцах B, C и D со значением A, которое содержит полный список возможных строк. Кроме того, значения в каждом столбце сортируются, так что это случай уменьшения ячеек до тех пор, пока они не выровняются со столбцом A, что я и делал вручную, но хочу автоматизировать:
У меня ограниченный опыт работы с Excel, но все исследования привели меня к использованию этого кода в модуле. К сожалению, когда он запускается, он мало что для меня делает. Со второй попытки, в меру своих способностей, я пытался настроить код так, чтобы он соответствовал диапазону значений в моем листе, но я не могу заставить его работать. Поэтому я надеюсь, что если более опытные участники сообщат мне, действительно ли мне нужно, чтобы код соответствовал моим данным или он просто работал? Спасибо за любую помощь, которую вы можете оказать или просто нашли время, чтобы прочитать!
Option Explicit
Sub AlignCustNbr()
' hiker95, 01/10/2011
' http://www.mrexcel.com/forum/showthread.php?t=520077
'
' The macro was modified from code by:
' Krishnakumar, 12/12/2010
' http://www.ozgrid.com/forum/showthread.php?t=148881
'
Dim ws As Worksheet
Dim LR As Long, a As Long
Dim CustNbr As Range
Application.ScreenUpdating = False
Set ws = Worksheets("Sheet1")
LR = ws.Range("E" & ws.Rows.Count).End(xlUp).Row
ws.Range("E3:G" & LR).Sort Key1:=ws.Range("E3"), Order1:=xlAscending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
LR = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
ws.Range("A3:C" & LR).Sort Key1:=ws.Range("A3"), Order1:=xlAscending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
Set CustNbr = ws.Range("A2:C" & LR)
a = 2
Do While CustNbr.Cells(a, 1) <> ""
If CustNbr.Cells(a, 1).Offset(, 4) <> "" Then
If CustNbr.Cells(a, 1) < CustNbr.Cells(a, 1).Offset(, 4) Then
CustNbr.Cells(a, 1).Offset(, 4).Resize(, 3).Insert -4121
ElseIf CustNbr.Cells(a, 1) > CustNbr.Cells(a, 1).Offset(, 4) Then
CustNbr.Cells(a, 1).Resize(, 3).Insert -4121
LR = LR + 1
Set CustNbr = ws.Range("A3:C" & LR)
End If
End If
a = a + 1
Loop
Application.ScreenUpdating = 1
End Sub!
1 ответ
Я не очень хорош в VBA, но этот код может сделать это:
Option Explicit
Public Sub AlignCustNbr()
Dim ws As Worksheet
Dim i As Long
Application.ScreenUpdating = False
Set ws = ActiveSheet
For i = 2 To ws.Columns.Count
If (Trim(ws.Cells(1, i).Value & "") = "") Then
Exit For
End If
'
Call Align2Columns(ws, 1, i)
Next i
End Sub
Private Sub Align2Columns(ws As Worksheet, mainCol As Long, dataCol As Long)
Dim colData() As String
Dim strTemp As String, strTemp2 As String
Dim i As Long, j As Long
Dim lastDataRow As Integer
ReDim colData(1 To ws.Rows.Count)
lastDataRow = 1
'
'Findeing aligned datas to colData()
For i = 1 To ws.Rows.Count
strTemp = Trim(ws.Cells(i, dataCol).Value & "")
If (strTemp = "") Then
Exit For
End If
'
For j = 1 To ws.Rows.Count
strTemp2 = Trim(ws.Cells(j, mainCol).Value & "")
If (strTemp2 = "") Then
lastDataRow = lastDataRow + 1
colData(j + lastDataRow) = strTemp2
Exit For
' to avoid cese sensetive use commented line
'ElseIf (UCase(strTemp) = UCase(strTemp2)) Then
ElseIf (strTemp = strTemp2) Then
colData(j) = strTemp2
Exit For
End If
Next j
Next i
'
'Update dataCol
i = 0
Do
i = i + 1
ws.Cells(i, dataCol).Value = colData(i)
If (Trim(ws.Cells(i, mainCol).Value & "") = "") Then
lastDataRow = lastDataRow - 1
End If
Loop While lastDataRow > 0
End Sub