Question

我正在尝试在Excel工作表上组织一组数据。如果我不能很好地解释我的最终目标，我对vba很新，所以道歉......我在黑暗中盲目地感受到这一点！基本上我正在尝试执行以下操作：用户将在不同的单元格中输入一些数据，并输入与数据相关的图片。有一个单元格，在这个单元格中，他们输入了他们希望数据显示的顺序（请参阅下图中A列中的故障编号（工作表的屏幕截图））。 Screenshot of worksheet

因此，例如 - 他们将输入2个不同“故障”的信息，它们的顺序为2,1。（这是一个简单的例子 - 最多有80个'故障'）点击“组织故障”按钮，数据将重新排列。我没有问题重新排列文本，这是完美的。我遇到的问题是抓住与数据相关的图片。我已经尝试了很多不同的方法来完成这项工作并完全失败。

下面是我重新排列的代码 - 我所做的是创建一个'错误'对象。单击“组织故障”按钮，会创建一系列故障，根据故障编号按顺序重新排列故障，然后将它们粘贴到正确的位置。在此子区域内调用“移动较大的图像”/“移动较小的图像”。

我知道我的代码很长，但为了清楚起见，我将其放入。相关部分在最后 - “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: " & 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: " & 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" & 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：

Sub MoveLargeImage(i As Integer, j As Integer)

    Dim r As Range
    Set r = Range("J" & CStr(i) & ":J" & 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" & CStr(i) & ":J" & CStr(i + 29)),  _
                                           oShape.TopLeftCell) Is Nothing Then
                oShape.Name = "LargeImage" & 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" & CStr(p) & ":J" & CStr(p + 19))
    End If
End Sub

这里是'MoveSmallerImage'子（几乎相同的期望结果 - 只是不同的定位）

Sub MoveSmallImage(i As Integer, j As Integer)

    Dim r As Range
    Set r = Range("E" & CStr(i) & ":E" & 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" & CStr(i) & ":E" & CStr(i + 10)), _
                                          oShape.TopLeftCell) Is Nothing Then
            oShape.Name = "SmallImage" & 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" & CStr(p) & ":E" & CStr(p + 7))
    End If
End Sub

谢谢！

Answer 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

重新排列一组图片VBA

1 个答案: