附件是我最常用的工作表格 我其中的一项任务就是根据相应的款号搜寻相关的文件(PDF/AI/纯JPG极少几乎没有)，由于大量文件都是PDF/AI格式我都是直接Adobe打开用照相机功能截取一小块然后复制相对应的单元格，其实这些都没有什么的，郁闷就在于由于截取的图片大小都不一致 自己也无法判断 致使截取的图片在复制入相对应的单元格时会时会儿大时会儿小 排列后非常不美观 其次也容易上下遮掩出错 目前我都是每次复制一张图片就手动调节一次 非常繁琐~！！！而附件是我工作表格总量中很小很小的一部分而已~！！！::(
现在请教哪位大神帮忙写一个针对我通过复制而非插入的图片进行对应单元格适应 如个别图片较小则不必适应单元格而自动置中
谢谢~:loveliness:
(80.1 KB, 下载次数: 14)
12:35 上传
下载次数: 14
12:35 上传
下载次数: 33
255.8 KB, 下载次数: 33
我地呢班打工仔一生一世为钱币做奴隶
在线时间6154 小时经验48381 威望30 性别男最后登录注册时间阅读权限150UID151593积分48781帖子精华3分享2
管理以下版块
142079财富
积分排行1帖子精华3微积分0
★利用有效性信息批量调用信息和图片★& & & &
在线时间4914 小时经验11896 威望10 性别女最后登录注册时间阅读权限95UID218774积分13496帖子精华1分享0
积分排行38帖子精华1微积分0
介绍下面的代码
图片高和单元格行高可以准确对准，即系数为1。
但列宽和图片宽的系数不为1，我猜是6.125
Sub PicAdj()
& & K = 6.125
& & H = ActiveCell.RowHeight
& & W = ActiveCell.ColumnWidth
& & On Error Resume Next
& & PH = Selection.ShapeRange.Height
& & If Err.Number && 0 Then
& && &&&Err.Clear
& && &&&MsgBox &Picture not selected ! &
& && &&&Exit Sub
& & End If
& & PW = Selection.ShapeRange.Width
& & RH = PH / H
& & RW = PW / W / K
& & Selection.ShapeRange.LockAspectRatio = msoTrue
& & If RH & RW Then
& && &&&Selection.ShapeRange.Height = PH / RH
& && &&&Selection.ShapeRange.Width = PW / RH
& && &&&Selection.ShapeRange.Height = PH / RW
& && &&&Selection.ShapeRange.Width = PW / RW
& & End If
& & PH = Selection.ShapeRange.Height
& & PW = Selection.ShapeRange.Width
& & If ActiveCell.Row = 1 Then
& && &&&CH = 0
& && &&&CH = Range(&A1&, ActiveCell.Offset(-1, 0)).Height
& & End If
& & If ActiveCell.Column = 1 Then
& && &&&CW = 0
& && &&&CW = Range(&A1&, ActiveCell.Offset(0, -1)).Width
& & End If
& & Selection.Top = CH + (H - PH) / 2
& & Selection.Left = CW + (W * K - PW) / 2
& & ActiveCell.Offset(1, 0).Select
[ 本帖最后由 香川群子 于
15:56 编辑 ]
在线时间127 小时经验167 威望0 性别保密最后登录注册时间阅读权限20UID835528积分167帖子精华0分享0
EH初级, 积分 167, 距离下一级还需 183 积分
积分排行3000+帖子精华0微积分0
回复 3楼 香川群子 的帖子
HI 香川 感谢啊
实际用了下 感觉挺好的 但我觉得也许尺寸还是个问题下如图
[ 本帖最后由 cango.hu 于
18:20 编辑 ]
(106.26 KB, 下载次数: 9)
18:07 上传
下载次数: 9
(75.43 KB, 下载次数: 8)
18:07 上传
下载次数: 8
(72.9 KB, 下载次数: 7)
18:20 上传
下载次数: 7
我地呢班打工仔一生一世为钱币做奴隶
在线时间1499 小时经验2739 威望16 性别男最后登录注册时间阅读权限50UID138127积分4289帖子精华4分享0
积分排行217帖子精华4微积分0
能不能这样？虽然你使用手动复制图片的大小比较难以控制，但是也不会相差太大，其实可以设置一个合适的列宽，然后调节图片的宽度来使用列宽，图片的宽带如果小于列宽，则置中，如果大于列宽，则缩小。然后主要是调节行高。
另外操作步骤是不是这样的？复制图片到工作表，然后选择目标单元格，再选择图片，然后运行宏，执行宏将图片置于目标单元格之中。
在线时间4914 小时经验11896 威望10 性别女最后登录注册时间阅读权限95UID218774积分13496帖子精华1分享0
积分排行38帖子精华1微积分0
原帖由 LangQueS 于
13:10 发表
★利用有效性信息批量调用信息和图片★& & & &
该相关部分的主要代码为：
Sub test()
& & Dim r As Range
& & Set r = ActiveCell
& & '先选择单元格范围，
&&'然后选择图片
& & With Selection
& && &&&ta = Range(r.MergeArea.Address).Height& & '(合并)单元高度
& && &&&tb = Range(r.MergeArea.Address).Width& &&&'(合并)单元宽度
& && &&&tc = .Height& & '图片高度
& && &&&td = .Width& &&&'图片宽度
& && &&&tm = Application.WorksheetFunction.Min(ta / tc, tb / td)& & '单元与图片之间长宽差异比例的最小值
& && &&&.Height = .Height * tm& & '按比例调整图片宽度
& && &&&.Width = .Width * tm& && &'按比例调整图片高度
& && &&&.Top = r.Top + (r.MergeArea.Height - .Height) / 2 '垂直居中:
& && && && &&&.Left = r.Left + (r.MergeArea.Width - .Width) / 2& &'水平居中:
& & End With
[ 本帖最后由 香川群子 于
21:31 编辑 ]
积分≥4700即可申请
最佳管理者
最佳管理者奖章No.1
金牌优秀管理者
金牌优秀管理者勋章No.1
金牌优秀管理者
金牌优秀管理者勋章No.2
优秀管理者
优秀管理者勋章No.1
优秀管理者
优秀管理者勋章No.2
金牌优秀会员
金牌优秀会员奖章No.1
优秀会员奖章No.1
金牌优秀会员
金牌优秀会员奖章No.3
金牌优秀会员
金牌优秀会员奖章No.2
优秀会员奖章No.4
优秀会员奖章No.3
优秀会员奖章No.2
- 注意：自起，未完成邮箱认证的会员将无法发帖！如何完成邮箱认证？请点击下方“查看”。
关注我们，与您相约微信公众平台！
Copyright 1999 - 2017 Excel Home. All Rights Reserved.本论坛言论纯属发表者个人意见，任何违反国家相关法律的言论，本站将协助国家相关部门追究发言者责任！
Powered by
本站特聘法律顾问：徐怀玉律师 李志群律师 &&我编了个vba代码&&能在excel中运行& &但是如果数据一多&&在excel中运行就会很慢& &如果代码在复杂点就更不用说要有多慢就有多慢
现在 我想 能不能&&吧excel中的 数据链接到 access中 然后 在access中运行代码 输出结果&&再把 结果链接到excel&&这样是不是会快点&&主要是因为在excel中运行vba太慢
求大神解脱在下&&谢谢& &例子在附件里& &不知能不能实现 或者 access直接调用 excel中的 代码
15:19 上传
下载次数: 5
15.29 KB, 下载次数: 5
在线时间217 小时经验81 威望0 性别男最后登录注册时间阅读权限20UID1838458积分81帖子精华0分享0
EH初级, 积分 81, 距离下一级还需 269 积分
积分排行3000+帖子精华0微积分0
这&&大家给个方向呗&&
在线时间23636 小时经验38550 威望25 性别男最后登录注册时间阅读权限150UID501055积分41350帖子精华2分享0
管理以下版块
136347财富
积分排行4昵称请模拟效果帖子精华2微积分0
原来的代码太蹩脚了，换个方法试试看：Sub bbb()
& & Dim d As Object, arr, i&, j&, s$, m&, t
& & Set d = CreateObject(&Scripting.Dictionary&)
& & arr = Sheet1.[a1].CurrentRegion
& & m = 1
& & For i = 2 To UBound(arr)
& && &&&s = arr(i, 1) & &[& & arr(i, 2)
& && &&&t = d(s)
& && &&&If t = && Then
& && && && &m = m + 1
& && && && &d(s) = m
& && && && &For j = 1 To 3
& && && && && & arr(m, j) = arr(i, j)
& && && && &Next
& && &&&Else
& && && && &arr(t, 3) = arr(t, 3) + arr(i, 3)
& && &&&End If
& & Next
& & Sheet2.[a1].Resize(m, 3) = arr
& & Set d = Nothing
End Sub复制代码
在线时间23636 小时经验38550 威望25 性别男最后登录注册时间阅读权限150UID501055积分41350帖子精华2分享0
管理以下版块
136347财富
积分排行4昵称请模拟效果帖子精华2微积分0
(20.77 KB, 下载次数: 21)
19:04 上传
下载次数: 21
如果使用Access存放数据，可以使用ADO+SQL方法调出数据到Excel中
在线时间217 小时经验81 威望0 性别男最后登录注册时间阅读权限20UID1838458积分81帖子精华0分享0
EH初级, 积分 81, 距离下一级还需 269 积分
积分排行3000+帖子精华0微积分0
zhaogang1960 发表于
谢谢老师，&&但是有没有方法&&在access中 运算&&再把结果导出到excel&&比如：按行读取数据，我们要求该行所对应的余下所有行数据之和&&那么 如果有60000行数据&&在excel 中他就要&&算（1+60000）*60000/2次&&这样在excel中会很慢，有没有方法是在access调用vba语言 运算
在线时间23636 小时经验38550 威望25 性别男最后登录注册时间阅读权限150UID501055积分41350帖子精华2分享0
管理以下版块
136347财富
积分排行4昵称请模拟效果帖子精华2微积分0
Passaway 发表于
谢谢老师，&&但是有没有方法&&在access中 运算&&再把结果导出到excel&&比如：按行读取数据，我们要求该行 ...
（1+60000）*60000/2次&&这个结论是怎么得出来的？
我认为一种算法不管在哪个软件中的VBA运行，计算次数是一样的
如果需要把Access数据表数据导入到Excel中，使用ADO+SQL就可以了
在线时间217 小时经验81 威望0 性别男最后登录注册时间阅读权限20UID1838458积分81帖子精华0分享0
EH初级, 积分 81, 距离下一级还需 269 积分
积分排行3000+帖子精华0微积分0
zhaogang1960 发表于
（1+60000）*60000/2次&&这个结论是怎么得出来的？
我认为一种算法不管在哪个软件中的VBA运行，计算次数 ...
嗯&&这倒也是 一种算法不管在哪个软件中的VBA运行，计算次数是一样的，但是相比excel access处理大数据来的方便 所以 我想问下有没有在access运算的办法&&：）
在线时间23636 小时经验38550 威望25 性别男最后登录注册时间阅读权限150UID501055积分41350帖子精华2分享0
管理以下版块
136347财富
积分排行4昵称请模拟效果帖子精华2微积分0
Passaway 发表于
嗯&&这倒也是 一种算法不管在哪个软件中的VBA运行，计算次数是一样的，但是相比excel access处理大数据来 ...Sub ADO法()
& & '引用Microsoft AD0 Ext 2.8 for DDL and Security
& & Dim cnn As New ADODB.Connection
& & Dim rs As New ADODB.Recordset
& & Dim SQL$
& & cnn.Open &Provider=Microsoft.Jet.Oledb.4.0;data Source=& & ThisWorkbook.Path & &\db1.mdb&
& & SQL = &Select 款号,尺码,sum(数量) as 数量 from Sheet1 group by 款号,尺码&
& & rs.Open SQL, cnn, adOpenKeyset, adLockOptimistic
& & Cells.ClearContents
& & For i = 1 To rs.Fields.Count
& && &&&Cells(1, i) = rs.Fields(i - 1).Name
& & Next
& & [a2].CopyFromRecordset rs
& & rs.Close
& & cnn.Close
& & Set rs = Nothing
& & Set cnn = Nothing
End Sub复制代码
在线时间23636 小时经验38550 威望25 性别男最后登录注册时间阅读权限150UID501055积分41350帖子精华2分享0
管理以下版块
136347财富
积分排行4昵称请模拟效果帖子精华2微积分0
假设数据库名叫db1.mdb、数据表名叫Sheet1
(22.46 KB, 下载次数: 23)
19:48 上传
下载次数: 23
本帖评分记录鲜花
总评分:&鲜花 + 2&
在线时间217 小时经验81 威望0 性别男最后登录注册时间阅读权限20UID1838458积分81帖子精华0分享0
EH初级, 积分 81, 距离下一级还需 269 积分
积分排行3000+帖子精华0微积分0
zhaogang1960 发表于
假设数据库名叫db1.mdb、数据表名叫Sheet1
太谢谢老师了&&学习了
积分≥4700即可申请
最佳管理者
最佳管理者奖章No.4
最佳管理者
最佳管理者奖章No.3
最佳管理者
最佳管理者奖章No.2
最佳管理者
最佳管理者奖章No.1
金牌优秀管理者
金牌优秀管理者勋章No.1
优秀管理者
优秀管理者勋章No.1
金牌优秀会员
金牌优秀会员奖章No.2
金牌优秀会员
金牌优秀会员奖章No.1
优秀会员奖章No.2
优秀会员奖章No.1
- 注意：自起，未完成邮箱认证的会员将无法发帖！如何完成邮箱认证？请点击下方“查看”。
关注我们，与您相约微信公众平台！
Copyright 1999 - 2017 Excel Home. All Rights Reserved.本论坛言论纯属发表者个人意见，任何违反国家相关法律的言论，本站将协助国家相关部门追究发言者责任！
Powered by
本站特聘法律顾问：徐怀玉律师 李志群律师 &&十万火急，恳求各路大侠英雄帮忙解决一个EXCEL中的VBA难题
十万火急，恳求各路大侠英雄帮忙解决一个EXCEL中的VBA难题 30
EXCEL中用VBA编程时引用单元格可以用Range&或cells等等，如Range("A1:D10") Cells(1,10),Cells(1,10)中的1，10都可用变量如i代替，但Range("A1:D10") 中的
A1:D10能否用变量表达呀，怎么表达呀，请举例说明，求求各位高手来帮下我这个新手好吗，本人感激不尽，能解决问题是话我另加50分。
range设置变量时要用Set语句才行,如:
Dim Rng as Range'声明变量
Set Rng = Range("A1:D10")
你误解我的意思了，我的意思是指用组成的表达式表达要选择的区域如ch1,ch2是两个变量，我想用“ch1:ch2”表示选择的区域，当ch1,ch2变化时，选择的区域也跟着变化而不是你说的那样将选定的区域作常量赋给变量
也可以固定行，列作，或反过来，固定列，行作变量等，如：
Range("A1:D" & i)&& ' i为变量,其它组合方式也可以,但要注意非变量的要用括起来.
的感言：十分感谢你的帮忙，有困难就应找你这样的人帮忙
等待您来回答
微软专区领域专家本帖最后由 ygs1225 于
17:21 编辑
各位老师、大神好：
& && & 进来请留步，这个问题困扰我很久了，自己始终只能实现部分功能，做不完整，麻烦各位帮帮忙，要求如下：
1、希望编号能按每页自动编号（在表头里），以本附件为例就是依次为6-1、6-2、6-3。。。（6代表的是月份）
2、每页固定24个人（即不包含标题、合计为48行），工资为0的自动隐藏（不能删除），打印时隐藏的行不包含进去，意思就是每页打印出来有24个人。
(30.08 KB, 下载次数: 11)
11:11 上传
下载次数: 11
在线时间215 小时经验188 威望0 性别保密最后登录注册时间阅读权限20UID1015976积分188帖子精华0分享0
EH初级, 积分 188, 距离下一级还需 162 积分
积分排行3000+帖子精华0微积分0
真的没人能帮忙吗？
在线时间11189 小时经验6297 威望2 性别男最后登录注册时间阅读权限95UID200718积分6497帖子精华0分享0
积分排行132帖子精华0微积分0
本帖最后由 yaozong 于
12:57 编辑
Private Sub CommandButton1_Click()
Dim arr, i&, j&, k&, m&, n&
arr = Sheet2.Range(&a6&, Sheet2.[a65536].End(3).Offset(-1, 23))
x = UBound(arr, 2)
ReDim brr(1 To UBound(arr), 1 To x)
For i = 1 To UBound(arr)
& &If arr(i, 3) & 0 Then
& && &m = m + 1
& && &For j = 1 To x
& && && &brr(m, j) = arr(i, j)
& && &Next
For i = 1 To m Step 48
& & n = n + 1
& & ReDim crr(1 To 48, 1 To 24)
& & For k = 1 To 48
& && & For j = 1 To x
& && && & crr(k, j) = brr(i + k - 1, j)
& && & Next
& & With Sheets(&打印页&)
& && & .[a6:x53] = &&
& && & .[a6:x53] = crr
& && & .[v3] = &6-& & n
& && & .PrintPreview& &'先预览(调试用)
& && &' .PrintOut& && &'后打印(调试没问题后)
& & End With
12:57 上传
下载次数: 10
26.62 KB, 下载次数: 10
在线时间215 小时经验188 威望0 性别保密最后登录注册时间阅读权限20UID1015976积分188帖子精华0分享0
EH初级, 积分 188, 距离下一级还需 162 积分
积分排行3000+帖子精华0微积分0
yaozong 发表于
Private Sub CommandButton1_Click()
Dim arr, i&, j&, k&, m&, n&
arr = Sheet2.Range(&a6&, Sheet2.[a6 ...
太谢谢了，如果想单独打印其中某一页或某几页有办法实现吗？
在线时间215 小时经验188 威望0 性别保密最后登录注册时间阅读权限20UID1015976积分188帖子精华0分享0
EH初级, 积分 188, 距离下一级还需 162 积分
积分排行3000+帖子精华0微积分0
yaozong 发表于
Private Sub CommandButton1_Click()
Dim arr, i&, j&, k&, m&, n&
arr = Sheet2.Range(&a6&, Sheet2.[a6 ...
还有个小问题，编号“6-1、6-2”里边的6代表的是当前月份，能不能从前边的“日至日”里边提取，后边那个月份
在线时间215 小时经验188 威望0 性别保密最后登录注册时间阅读权限20UID1015976积分188帖子精华0分享0
EH初级, 积分 188, 距离下一级还需 162 积分
积分排行3000+帖子精华0微积分0
yaozong 发表于
Private Sub CommandButton1_Click()
Dim arr, i&, j&, k&, m&, n&
arr = Sheet2.Range(&a6&, Sheet2.[a6 ...
请再帮帮呀，有重复的好像统计不进去
(92.39 KB, 下载次数: 5)
17:16 上传
下载次数: 5
在线时间11189 小时经验6297 威望2 性别男最后登录注册时间阅读权限95UID200718积分6497帖子精华0分享0
积分排行132帖子精华0微积分0
ygs1225 发表于
请再帮帮呀，有重复的好像统计不进去
'...................
19:18 上传
下载次数: 8
34.32 KB, 下载次数: 8
在线时间11189 小时经验6297 威望2 性别男最后登录注册时间阅读权限95UID200718积分6497帖子精华0分享0
积分排行132帖子精华0微积分0
本帖最后由 yaozong 于
19:53 编辑
ygs1225 发表于
请再帮帮呀，有重复的好像统计不进去
1楼附件最后有&合计&
6楼附件怎么没有了(没有&合计&就少计最后的数据)
如果最后合计不需要的,arr改为:
arr = Sheet2.Range(&a6&, Sheet2.[a65536].End(3).Offset(1, 23))
在线时间1126 小时经验1025 威望0 最后登录注册时间阅读权限50UID1100552积分1125帖子精华0分享0
EH高级, 积分 1125, 距离下一级还需 875 积分
积分排行945帖子精华0微积分0
22:04 上传
(33.82 KB, 下载次数: 14)
22:05 上传
下载次数: 14
人往往总是以一套自己的理论去理解别人，以获得慰藉。
在线时间1126 小时经验1025 威望0 最后登录注册时间阅读权限50UID1100552积分1125帖子精华0分享0
EH高级, 积分 1125, 距离下一级还需 875 积分
积分排行945帖子精华0微积分0
全部代码在这儿
Option Base 1
Dim hh()& & '动态数组，存放工资额&0的行号
Private Sub UserForm_Initialize()
& & Dim i As Integer, n As Integer
& & For i = 1 To 12
& && &&&ComboBox1.AddItem i
& & Next
& & ComboBox1 = Month(Date)
& & For i = 6 To Sheet2.Range(&A65536&).End(3).Row
& && &&&If Sheet2.Range(&W& & i) && 0 Then
& && && && &n = n + 1: ReDim Preserve hh(n)
& && && && &hh(n) = i
& && &&&End If
& & Next
& & If n = 0 Then Label2.Caption = &工资表中没有“实得工资”不为 0 的记录！&
& & TextBox1 = 24
& & Sheet3.Activate
End Sub
Private Sub TextBox1_Change()
& & Dim i As Integer
& & ListBox1.Clear
& & If Val(TextBox1) & 1 Then Exit Sub&&'除数不得为零
& & For i = 1 To WorksheetFunction.RoundUp(UBound(hh()) / Val(TextBox1), 0)
& && &&&ListBox1.AddItem &第 & & i & & 页&
& & Next
& & Label2.Caption = &■ 提示：共有 & & UBound(hh()) & & 条记录，& + Chr(10) + Chr(10) + && &分 & & ListBox1.ListCount & & 页打印。&
End Sub
Private Sub ListBox1_Click()
& & Dim r1 As Long, r2 As Long, i As Integer, x As Integer
& & Application.ScreenUpdating = False
& & Application.DisplayAlerts = False
& & Sheet3.Range(&W3&) = ComboBox1 & &-& & ListBox1.ListIndex + 1
& & Sheet3.Range(&A6:X53&) = &&
& & r1 = ListBox1.ListIndex * Val(TextBox1) + 1
& & r2 = (ListBox1.ListIndex + 1) * Val(TextBox1)
& & x = 6
& & For i = r1 To r2
& && &&&If i & UBound(hh) Then Exit For
& && &&&Sheet2.Range(&A& & hh(i) & &:X& & hh(i) + 1).Copy
& && &&&Sheet3.Range(&A& & x).PasteSpecial
& && &&&x = x + 2
& & Next
& & Range(&A6&).Select
& & Application.DisplayAlerts = True
& & Application.ScreenUpdating = False
End Sub复制代码
人往往总是以一套自己的理论去理解别人，以获得慰藉。
优秀会员奖章No.2
优秀会员奖章No.1
积分≥4700即可申请
- 注意：自起，未完成邮箱认证的会员将无法发帖！如何完成邮箱认证？请点击下方“查看”。
关注我们，与您相约微信公众平台！
Copyright 1999 - 2017 Excel Home. All Rights Reserved.本论坛言论纯属发表者个人意见，任何违反国家相关法律的言论，本站将协助国家相关部门追究发言者责任！
Powered by
本站特聘法律顾问：徐怀玉律师 李志群律师 &&}