[已解决]再次求助，代碼修改

心正意诚身修

昨天有個發了個求助。有老師幫我完成了。昨天的要求是模擬是直接一排顯示下去，現在要按三排。附件有模擬結果。麻煩老師們再幫我改改。
因為我這裡是繁體版。附件到我這裡是看不見漢字的。全是亂碼，老師帖的時候最好帖代碼進去，遇到漢字。我可以重新打一敲。謝謝老師們了。

最佳答案

月排行榜 / 总排行榜

爱疯

2016-4-28 15:11

3.rar (1.65 MB, 下载次数: 6)

2016-4-28 15:07 上传

点击文件名下载附件



1）代码没改
2）用1024个图片测试，没发现报错啊？要不你发一个执行出错的动画

跳转到最佳答案楼层

爱疯

Option Explicit

'**************************************************************************************
'功能：A列和C列返回图片数据，B列插入图片
'http://www.excelpx.com/thread-417091-1-1.html
'http://www.excelpx.com/thread-417105-1-1.html
Sub checkLogo()
    Dim A()
    Dim path As String
    Dim file As String
    Dim i As Integer
    Dim r As Integer    '实际行号
    Dim c As Integer    '实际列号
    Dim x As Integer    '一行几组（1个logo1个图片1个user为1组）


    Application.ScreenUpdating = False
    Call init
    path = ThisWorkbook.path & "\LOGO圖檔\"
    file = Dir(path)
    x = 3
    ReDim A(1 To 10 ^ 4, 1 To 3 * x)


    Do While file <> ""
        '将i转为实际行列
        i = i + 1
        r = getRow(i, x) + 1    '因为有1行标题，所以下移1行
        c = getColumn(i, x)
        c = (c - 1) * 3 + 2

        '插入图片。自行统一单元格的列宽和行高
        With Cells(r, c)
            ActiveSheet.Shapes.AddPicture _
                    Filename:=path & file, LinkToFile:=True, SaveWithDocument:=False, _
                    Left:=.Left, Top:=.Top, Width:=.Width, Height:=.Height
        End With

        '录入信息
        file = Left(file, Len(file) - 4)
        If InStr(file, "-") Then
            A(r, c - 1) = VBA.Split(file, "-")(0)    'logo
            A(r, c + 1) = VBA.Split(file, "-")(1)    'user
        Else
            A(r, c - 1) = file
        End If
        file = Dir
    Loop


    [a1].Resize(r, UBound(A, 2)) = A
    For i = 1 To UBound(A, 2) Step 3
        Cells(1, i).Resize(1, 3) = Array("LOGO#", "圖案", "客戶")
    Next i
    Call SetOnAction    '可选功能
End Sub

'单击时被执行的宏
Private Sub SetOnAction()
    Dim shp As Shape
    For Each shp In ActiveSheet.Shapes
        If shp.Type = msoLinkedPicture Then shp.OnAction = "ActionClick"
    Next
End Sub

'单击时的动作
Private Sub ActionClick()
    Dim zoom As Integer
    zoom = 3    '指定放大系数
    With ActiveSheet.Shapes(Application.Caller)
        .ZOrder msoBringToFront
        If .Width = Range("b:b").Width Then    '指定图片的列
            .Width = .Width * zoom: .Height = .Height * zoom
        Else
            .Width = .Width / zoom: .Height = .Height / zoom
        End If
    End With
End Sub

'获取行
Function getRow(x, y)
    getRow = IIf(x \ y = x / y, x \ y, x \ y + 1)
End Function

'获取列
Function getColumn(x, y)
    getColumn = IIf(x Mod y, x Mod y, y)
End Function

'初始化（清除操作）
Private Sub init()
    With Cells
        .Clear
        .RowHeight = 100
        .ColumnWidth = 18
    End With
    Rows(1).RowHeight = 27
    ActiveSheet.Pictures.Delete
End Sub

2.rar (119.83 KB, 下载次数: 5)

2016-4-28 10:46 上传

点击文件名下载附件

心正意诚身修

愛瘋老師，在運行的時候，這句出錯。說是未定義。

    [a1].Resize(r, UBound(A, 2)) = A
麻煩再看下。上午開會。

心正意诚身修

爱疯 发表于 2016-4-28 10:48
Option Explicit

'******************************************************************************** ...

麻煩看下，我該怎麼改呢，惟一的變化是。現在的圖片是722張。

爱疯

3.rar (1.65 MB, 下载次数: 6)

2016-4-28 15:07 上传

点击文件名下载附件



1）代码没改
2）用1024个图片测试，没发现报错啊？要不你发一个执行出错的动画

心正意诚身修

爱疯 发表于 2016-4-28 15:11
1）代码没改
2）用1024个图片测试，没发现报错啊？要不你发一个执行出错的动画

現在圖片過來了。可是原檔案的名字。。沒出來。。公司電腦，錄不了GIF。