#excel #vba
#excel #vba
Вопрос:
Я пытаюсь упорядочить набор данных на листе Excel. Я очень новичок в vba, поэтому прошу прощения, если я не очень хорошо объясняю свою конечную цель…С этим я вслепую нащупываю в темноте! В основном я пытаюсь сделать следующее: пользователь вводит некоторые данные в разные ячейки и изображение, связанное с данными. Есть ячейка, в которую они вводят порядок, в котором они хотели бы отображать данные (см. Номер ошибки в столбце A на рисунке ниже (скриншот рабочего листа)). 
Так, например, — они будут вводить информацию для 2 разных «ошибок», и они расположены в порядке 2, 1. (Это упрощенный пример — будет до 80 «ошибок») При нажатии кнопки «Упорядочить ошибки» данные будут переставлены. У меня нет проблем с перестановкой текста, и это работает отлично. У меня возникла проблема с захватом изображения, связанного с данными. Я перепробовал множество разных способов сделать это и нахожусь в полной растерянности.
Ниже приведен мой код для перестановки — то, что я сделал, это создал объект ‘fault’. При нажатии кнопки «Упорядочить ошибки» создается массив ошибок, они упорядочиваются в соответствии с номером ошибки, а затем вставляются в нужное место. В этом подразделе вызываются подразделы «Переместить изображение большего размера» / «Переместить изображение меньшего размера».
Я знаю, что мой код многословен, но я добавляю его для ясности. Соответствующий раздел находится в конце — либо подраздел ‘MoveLargerImage’ / ‘MoveSmallerImage’. Как только я получу один рабочий, я почти уверен, что смогу заставить работать второй, поскольку он делает то же самое. Любые указания в правильном направлении очень ценятся.
Благодарю вас!
Public Sub ReArrangeFaults()
'Set up a counter to hold the array length
Dim arrayLength As Integer
arrayLength = 0
'Set counter to indicate cells
Dim i As Integer
i = 6
'Set a counter
Dim counter As Integer
counter = 0
'*******************Loop through to count faults********************************
While Len(Worksheets("Analysis").Cells(i, 1)) <> 0
arrayLength = arrayLength 1
i = i 30
'MsgBox "Count at: " amp; arrayLength
Wend
'*******************Loop end********************************
'Reset i
i = 6
'*****Set up an array in which faults will be held and loop through to populate it*****
Dim faultArray() As cFault
ReDim faultArray(0 To arrayLength) As cFault
Dim oShape As Shape
Dim shapeName As String
While counter < arrayLength
'Create a fault class and assign all variables
Dim f As cFault
f.faultNumber = Worksheets("Analysis").Cells(i, 1)
f.Priority = Worksheets("Analysis").Cells(i, 3)
f.Location = Worksheets("Analysis").Cells(i 1, 3)
f.EquipmentID = Worksheets("Analysis").Cells(i 2, 3)
f.Component = Worksheets("Analysis").Cells(i 3, 3)
f.FigureNumber = Worksheets("Analysis").Cells(i 4, 3)
f.AnalysisParagraph = Worksheets("Analysis").Cells(i 11, 2)
f.ActionRequired = Worksheets("Analysis").Cells(i 21, 2)
f.StartPosition = Worksheets("Analysis").Cells(i, 1)
faultArray(counter) = f
'MsgBox "Count at: " amp; counter
i = i 30 'To set where to find data
counter = counter 1 'To increment loop
Wend
'*******************End array creation********************************
'*******************Sort array according to fault number**************
Dim SrtTemp As cFault
Dim m As Long
Dim n As Long
For m = 0 To arrayLength - 1
For n = m 1 To arrayLength - 1
If faultArray(m).faultNumber > faultArray(n).faultNumber Then
SrtTemp = faultArray(n)
faultArray(n) = faultArray(m)
faultArray(m) = SrtTemp
End If
Next n
Next m
'*******************End of sorting algorithm*************************
'*******************Loop through array and paste objects**************
counter = 0
i = 6
While counter < arrayLength
Worksheets("Analysis").Cells(i, 1) = faultArray(counter).faultNumber
Worksheets("Analysis").Cells(i, 3) = faultArray(counter).Priority
Worksheets("Analysis").Cells(i 1, 3) = faultArray(counter).Location
Worksheets("Analysis").Cells(i 2, 3) = faultArray(counter).EquipmentID
Worksheets("Analysis").Cells(i 3, 3) = faultArray(counter).Component
Worksheets("Analysis").Cells(i 4, 3) = faultArray(counter).FigureNumber
'Worksheets("Overview").Range("G10").Formula = "=COUNTIF('List of Leakages'!A2:A500,""<>"")"
Worksheets("Analysis").Cells(i 4, 3).Formula = "=A" amp; CStr(i)
Worksheets("Analysis").Cells(i 11, 2) = faultArray(counter).AnalysisParagraph
Worksheets("Analysis").Cells(i 21, 2) = faultArray(counter).ActionRequired
MoveLargeImage faultArray(counter).StartPosition, faultArray(counter).faultNumber
MoveSmallImage faultArray(counter).StartPosition, faultArray(counter).faultNumber
counter = counter 1
i = i 30
Wend
'*******************End Arranging objects*****************************
MsgBox "Organised!"
End Sub
Вот подраздел ‘MoveLargerImage’:
Sub MoveLargeImage(i As Integer, j As Integer)
Dim r As Range
Set r = Range("J" amp; CStr(i) amp; ":J" amp; CStr(i 29))
Dim oShape As Shape
Dim shapeName As String
shapeName = "nothing"
Dim p As Integer
If j > 1 Then
p = ((j - 1) * 30) 8
End If
If j = 1 Then
p = 8
End If
Dim count As Integer
count = 0
For Each oShape In ActiveSheet.Shapes
If (oShape.Type = msoPicture) Then
If Not Intersect(ActiveSheet.Range("J" amp; CStr(i) amp; ":J" amp; CStr(i 29)), _
oShape.TopLeftCell) Is Nothing Then
oShape.Name = "LargeImage" amp; i
shapeName = oShape.Name
End If
End If
Next oShape
If Not shapeName = "nothing" Then
Sheets("Analysis").Shapes(shapeName).Cut
Sheets("Analysis").Paste Sheets("Analysis").Range("J" amp; CStr(p) amp; ":J" amp; CStr(p 19))
End If
End Sub
И вот подраздел ‘MoveSmallerImage’ (практически тот же желаемый результат — просто другое позиционирование)
Sub MoveSmallImage(i As Integer, j As Integer)
Dim r As Range
Set r = Range("E" amp; CStr(i) amp; ":E" amp; CStr(i 29))
Dim oShape As Shape
Dim shapeName As String
shapeName = "nothing"
Dim p As Integer
If j > 1 Then
p = ((j - 1) * 30) 6
End If
If j = 1 Then
p = 6
End If
Dim count As Integer
count = 0
For Each oShape In ActiveSheet.Shapes
If Not Intersect(ActiveSheet.Range("E" amp; CStr(i) amp; ":E" amp; CStr(i 10)), _
oShape.TopLeftCell) Is Nothing Then
oShape.Name = "SmallImage" amp; i
shapeName = oShape.Name
End If
Next oShape
If Not shapeName = "nothing" Then
Sheets("Analysis").Shapes(shapeName).Cut
Sheets("Analysis").Paste Sheets("Analysis").Range("E" amp; CStr(p) amp; ":E" amp; CStr(p 7))
End If
End Sub
Спасибо!!
Комментарии:
1. В чем вопрос? Как переместить фигуру? Измените . Сверху и . Левое свойство объекта shape.
2. Спасибо, я понимаю, что свойства необходимо изменить, но то, что я пытаюсь сделать, это создать массив объектов fault и изменить их порядок. После того, как они будут изменены, они будут перемещены в их новые местоположения. В принципе, я не понимаю, как это сделать, это найти изображение в определенном месте, чтобы вырезать / вставить или изменить свойства. Например. Я знаю, что в ячейке E6 будет изображение с верхним левым углом. Чего я не могу сделать, так это захватить это изображение!!
Ответ №1:
Я думаю, что лучший способ — записывать имена изображений одновременно с заполнением класса ошибок. Поскольку имя каждого изображения уникально, вы будете знать, какие изображения идут с какой ошибкой. Перебор фигур — это единственный способ связать фигуру с диапазоном, так что вы правильно поняли эту часть. Добавьте в свой класс два свойства: SmallImageName и LargeImageName. Затем проверьте эту перезапись.
Во-первых, основная процедура
Public Sub ReArranageFaults2()
Dim colFaults As Collection
Dim i As Long
Dim lLastRow As Long
Dim sh As Worksheet
Dim clsFault As CFault
Dim rStart As Range
Set sh = ThisWorkbook.Worksheets("Analysis")
lLastRow = sh.Cells(sh.Rows.count, 1).End(xlUp).Row
Set colFaults = New Collection
'Loop through the worksheet skipping every 30 rows
'and fill an instance of CFault
'then add that object to the collection
For i = 5 To lLastRow Step 30
Set clsFault = New CFault
clsFault.FillFromRange sh.Cells(i, 1).Resize(30, 10)
colFaults.Add clsFault
Next i
'sort the collection by fault number
SortCollection colFaults
'Now loop through the collection and write
'the faults back to the worksheet
Set rStart = sh.Cells(5, 1)
For i = 1 To colFaults.count
Set clsFault = colFaults(i)
With rStart.Offset((i - 1) * 30, 0)
.Offset(1, 0).Value = clsFault.FaultNumber
.Offset(1, 2).Value = clsFault.Priority
.Offset(2, 2).Value = clsFault.Location
.Offset(3, 2).Value = clsFault.EquipmentID
.Offset(4, 2).Value = clsFault.Component
.Offset(5, 2).Value = clsFault.FigureNumber
.Offset(12, 1).Value = clsFault.AnalysisParagraph
.Offset(22, 1).Value = clsFault.ActionRequired
sh.Shapes(clsFault.SmallImageName).Left = .Offset(1, 4).Left
sh.Shapes(clsFault.SmallImageName).Top = .Offset(1, 4).Top
sh.Shapes(clsFault.LargeImageName).Left = .Offset(3, 9).Left
sh.Shapes(clsFault.LargeImageName).Top = .Offset(3, 9).Top
End With
Next i
End Sub
Я переместил заполнение объекта во внутренний класс, просто чтобы сохранить порядок
Public Sub FillFromRange(rRng As Range)
Dim shp As Shape
'Fill the properties
Me.FaultNumber = rRng.Cells(2, 1).Value
Me.Priority = rRng.Cells(2, 3).Value
Me.Location = rRng.Cells(3, 3).Value
Me.EquipmentID = rRng.Cells(4, 3).Value
Me.Component = rRng.Cells(5, 3).Value
Me.FigureNumber = rRng.Cells(6, 3).Value
Me.AnalysisParagraph = rRng.Cells(13, 2).Value
Me.ActionRequired = rRng.Cells(23, 2).Value
'Loop through all the shapes on the sheet
For Each shp In rRng.Parent.Shapes
'If it's within the range, it's either the large or the small
If Not Intersect(shp.TopLeftCell, rRng) Is Nothing Then
'If I haven't assigned a small yet, assume the first image
'is the small image
If Len(Me.SmallImageName) = 0 Then
Me.SmallImageName = shp.Name
Else 'I've already processed one image and assume it was the small
'If the already processed image is bigger than the current image
'then move small to large and save the current as small
If rRng.Parent.Shapes(Me.SmallImageName).Width > shp.Width Then
Me.LargeImageName = Me.SmallImageName
Me.SmallImageName = shp.Name
Else 'If the alread processed image is smaller than the current
'image, then it's in the right place, and we have only to
'store the large
Me.LargeImageName = shp.Name
End If
End If
End If
Next shp
End Sub
И, наконец, процедура сортировки коллекции. Я предпочитаю коллекцию массиву, если только я не делаю что-то конкретное, для чего требуется массив. Используя коллекцию, вы просто добавляете в нее по мере необходимости, вместо того, чтобы заранее определять размеры.
Public Sub SortCollection(ByRef col As Collection)
Dim i As Long
Dim j As Long
Dim obj As Object
For i = 1 To col.count - 1
For j = i To col.count
If col.Item(i).FaultNumber > col.Item(j).FaultNumber Then
Set obj = col.Item(i)
col.Remove i
col.Add obj, , , j - 1
End If
Next j
Next i
End Sub
Комментарии:
1. Спасибо!!!!! Это в основном то, что я изначально пытался сделать, но поскольку я на самом деле не работал с vb, я понятия не имел, как к этому подойти. Большое спасибо за такую детализацию, вы предотвратили множество седых волос 🙂