求Excel VBA代码：生成电子印章

weiyingde

很好，正合我意，谢谢你，费心了
说实话，手工制作，这个我会，无论ppt、word和excel，基本操作，我都可以。
也不瞒你说，这三个软件，我的使用经历也有好几年，
但以前，我都是用纯手工操作，自从学了VBA我就迷上了；
但是年纪大了，只是一种爱好，记性差，反应慢，学的东西不是很多，但足够应付平时工作；
对VBA我情有独钟，不忍放弃，幸亏遇上了你们这些热心人，
否则，我可能永远不会；
我们有专业的知识和基础，
只是下载了你们的一些精彩实例之后，
加以揣摩、修改和仿造，引进自己的工作当中；
录制宏，我也会一点，
不怕你笑话，复杂的，也就不会了
所以，再感谢你的同时，恳请将录制过程以动画的方式，传给我看看，我想学学。
再次感谢，
谢谢，谢谢！！

huang1314wei

weiyingde 发表于 2015-11-7 06:05
很好，正合我意，谢谢你，费心了
说实话，手工制作，这个我会，无论ppt、word和excel，基本操作，我都可以 ...

动画过程如下，录制宏有个缺点就是它把所有默认的属性都弄进来了，所以录制出来的代码无关内容太多，我们可以按F8单步执行
看一下哪些属性是我们要使用到的，然后引进自己的代码当中，把无关紧要的删除就是了，主要是学习属性的该怎么书写，VBA当
中对象、属性、方法太多，人不可能记得那么多属性方法，但是要用到的时候知道怎么去找就行
如果动画看不明白，可以参考百度上面的教程，网址如下：
http://jingyan.baidu.com/article/67508eb4daade99cca1ce4a7.html

gftrewq

huang1314wei 发表于 2015-11-6 22:11
excel做出来是这个效果，你满意我再放代码

第一个图像好像不对

weiyingde

是的，我也有同感，请你也看看

weiyingde

感谢huang1314wei

weiyingde

huang1314wei 发表于 2015-11-7 08:05
动画过程如下，录制宏有个缺点就是它把所有默认的属性都弄进来了，所以录制出来的代码无关内容太多，我们 ...

我想把每一个印章组合成一个整体，加了几句代码，但没有效果，不知错在哪里，请huang1314wei朋友给我看看，谢谢了

For j = 3 To rw
    If shp.TopLeftCell.adress = Range("D" & j).Address Or shp.Top = Range("D" & j).Top + 15 Or shp.Top = Range("D" & j).Top + Range("D" & j).Width - 20 Then
    shp.Select
    Selection.ShapeRange.Group
    End If
  Next

lcjy11185

这非常好。学习了。

huang1314wei

weiyingde 发表于 2015-11-7 19:04
我想把每一个印章组合成一个整体，加了几句代码，但没有效果，不知错在哪里，请huang1314wei朋友给我看看 ...

只给你提供一个示例代码哈，剩下的你依葫芦画瓢，我以D3单元格的当中的图形为例，代码如下：
Sub 组合图形()
    Dim myshape As Shape, i%, arr()
    For Each myshape In Sheet1.Shapes
        If myshape.TopLeftCell.Address = Range("D3").Address Then
            i = i + 1
            ReDim Preserve arr(i - 1)
            myshape.Name = Range("D3").Address & i
            arr(i - 1) = Range("D3").Address & i
        End If
    Next
    Sheet1.Shapes.Range(arr).Group
End Sub


另外，关于23楼提的问题，主要是因为那个图像超出了C3单元格范围，把C3单元格图片调整位置，使它的左上角位于C3单元格即可

huang1314wei

gftrewq 发表于 2015-11-7 09:23
第一个图像好像不对

主要是因为那个图片超出了C3单元格范围，把C3单元格图片调整位置，使它的左上角位于C3单元格即可，因为我提取的时候使用的是topleftcell属性，当时没有注意，感谢提醒！

weiyingde

真不好意思，我将你给的代码，稍作修改，如下：
Sub 组合图形()
    Dim myshape As Shape, i%, arr()
  rw = Sheets("图章参数").Range("a65536").End(xlUp).Row
  For j = 3 To rw
    For Each myshape In Sheet1.Shapes
        If myshape.TopLeftCell.Address = Range("D" & j).Address Then
            i = i + 1
            ReDim Preserve arr(i - 1)
            myshape.Name = Range("D" & j).Address & i
            arr(i - 1) = Range("D" & j).Address & i
        End If
    Next
    Sheet1.Shapes.Range(arr).Group
   Next
End Sub
目的是希望循环，可是仍然没有结果，是不是因为 Preserve的原因呢？还是因为其他原因。
得到你的帮助太多，真不好意思再缠你，可是……