[已解决]求助：请高手帮我设置个宏，谢谢！

真·アムロ

我想做个自动生成表单的宏，表单数据及表单的文字说明等都分别汇总放在不同的地方，想在另一张表格中自动生成表单

详细的看附件吧，里面有说明，很详细的

在这里先拜谢了！

PrwMXXul.rar (6.06 KB, 下载次数: 0)

2010-8-4 17:32 上传

点击文件名下载附件
求助：请高手帮我设置个宏，谢谢！

最佳答案

月排行榜 / 总排行榜

fgt258

2010-8-5 20:19

 

jdZikqJl.rar (13.21 KB, 下载次数: 0)

2010-8-5 20:18 上传

点击文件名下载附件
求助：请高手帮我设置个宏，谢谢！
插入A列后整个表向后移了一列

A列是隐藏的打印不出来的

跳转到最佳答案楼层

zxc1152468

[em01]

fgt258

Sub tgddn()
Application.ScreenUpdating = False
r = 7
cc = Sheet1.[a65536].End(xlUp).Row
Sheet1.Rows(r & ":" & cc).Clear

x = Sheet4.[a65536].End(xlUp).Row

Dim arry(1 To 19)

For i = 1 To x
If Sheet4.Cells(i, "a") = Sheet1.[c1] Then
 Sheet4.Rows(i).Copy
 
 Sheet1.Rows(r).PasteSpecial Paste:=xlPasteValues
 r = r + 1
End If
Next i
Application.CutCopyMode = False

Set d = Sheet5.range("a:a").Find(Sheet1.[c1])
Sheet1.Cells(r, "a") = Sheet5.Cells(d.Row, "b")

Application.ScreenUpdating = True

End Sub

真·アムロ

QUOTE:

以下是引用fgt258在2010-8-4 19:18:00的发言：

Sub tgddn()
Application.ScreenUpdating = False
r = 7
cc = Sheet1.[a65536].End(xlUp).Row
Sheet1.Rows(r & ":" & cc).Clear

x = Sheet4.[a65536].End(xlUp).Row

Dim arry(1 To 19)

For i = 1 To x
If Sheet4.Cells(i, "a") = Sheet1.[c1] Then
 Sheet4.Rows(i).Copy
 
 Sheet1.Rows(r).PasteSpecial Paste:=xlPasteValues
 r = r + 1
End If
Next i
Application.CutCopyMode = False

Set d = Sheet5.range("a:a").Find(Sheet1.[c1])
Sheet1.Cells(r, "a") = Sheet5.Cells(d.Row, "b")

Application.ScreenUpdating = True

End Sub

谢楼上

功能是基本达到了

似乎细节方面还不到位，比如说数值粘贴后表格格式变成空白了，我的意思是数值粘贴后再格式粘贴一次，这样就可以直接打出来了，还有“数据库”里的A列数据只是厂名识别用，这个没必要复制过来吧，如果不好改的话复制过来后删掉怎么样？

还有最后的说明，可能会出现一排显示不过的情况出现，能不能自动合并单元格至上面表格的宽度并设置自动换行？

似乎要求过多了，不过还是恳请楼上帮忙修改一下

再次拜谢了

fgt258

选中A列插入一列，隐藏A列，再这段试试，

Sub tgddn()
Application.ScreenUpdating = False
r = 7
cc = Sheet1.[b65536].End(xlUp).Row
Sheet1.Rows(r & ":" & 65536).Delete

x = Sheet4.[a65536].End(xlUp).Row

Dim arry(1 To 19)

For i = 1 To x
If Sheet4.Cells(i, "a") = Sheet1.[d1] Then
 Sheet4.Rows(i).Copy
 
 Sheet1.Rows(r).PasteSpecial Paste:=xlPasteValues
 Sheet1.Rows(r).PasteSpecial Paste:=xlPasteFormats
 r = r + 1
End If
Next i
Application.CutCopyMode = False

Set d = Sheet5.Range("a:a").Find(Sheet1.[d1])
Sheet1.Range(Cells(r, 2), Cells(r, "s")).Merge
Sheet1.Cells(r, 2).WrapText = True
Sheet1.Cells(r, "b") = Sheet5.Cells(d.Row, "b")
For g = 2 To Sheet1.Cells(r, "s").Column
o = Sheet1.Cells(r, g).ColumnWidth
u = u + o
Next
p = Len(Sheet1.Cells(r, 2))

h = p / u
n = Sheet1.Rows(r).Height

cce = Right(Round(h, 1) * 10, 1)
If cce >= 1 Then
Sheet1.Rows(r).RowHeight = n * (Int(h) + 1)

ElseIf cce = 0 Then
Sheet1.Rows(r).RowHeight = n * Int(h)
End If

Application.ScreenUpdating = True

End Sub

真·アムロ

QUOTE:

以下是引用fgt258在2010-8-4 22:53:00的发言：

选中A列插入一列，隐藏A列，再这段试试，

Sub tgddn()
Application.ScreenUpdating = False
r = 7
cc = Sheet1.[b65536].End(xlUp).Row
Sheet1.Rows(r & ":" & 65536).Delete

x = Sheet4.[a65536].End(xlUp).Row

Dim arry(1 To 19)

For i = 1 To x
If Sheet4.Cells(i, "a") = Sheet1.[d1] Then
 Sheet4.Rows(i).Copy
 
 Sheet1.Rows(r).PasteSpecial Paste:=xlPasteValues
 Sheet1.Rows(r).PasteSpecial Paste:=xlPasteFormats
 r = r + 1
End If
Next i
Application.CutCopyMode = False

Set d = Sheet5.Range("a:a").Find(Sheet1.[d1])
Sheet1.Range(Cells(r, 2), Cells(r, "s")).Merge
Sheet1.Cells(r, 2).WrapText = True
Sheet1.Cells(r, "b") = Sheet5.Cells(d.Row, "b")
For g = 2 To Sheet1.Cells(r, "s").Column
o = Sheet1.Cells(r, g).ColumnWidth
u = u + o
Next
p = Len(Sheet1.Cells(r, 2))

h = p / u
n = Sheet1.Rows(r).Height

cce = Right(Round(h, 1) * 10, 1)
If cce >= 1 Then
Sheet1.Rows(r).RowHeight = n * (Int(h) + 1)

ElseIf cce = 0 Then
Sheet1.Rows(r).RowHeight = n * Int(h)
End If

Application.ScreenUpdating = True

End Sub

谢楼上

貌似这段出错了

 

求助：请高手帮我设置个宏，谢谢！

麻烦您再看一下

fgt258

 

jdZikqJl.rar (13.21 KB, 下载次数: 0)

2010-8-5 20:18 上传

点击文件名下载附件
求助：请高手帮我设置个宏，谢谢！
插入A列后整个表向后移了一列

A列是隐藏的打印不出来的

真·アムロ

QUOTE:

以下是引用fgt258在2010-8-5 20:19:00的发言：

 

插入A列后整个表向后移了一列

A列是隐藏的打印不出来的

非常感谢楼上的帮助

最后能否再帮我增加一个功能

就是生成表单后自动设置打印区域，就是表头到生成的最后一行的区域自动设置打印区域，不然的话每次生成后由于不同单位之间行数以及宽度可能都不相同，打印区域都要重新设置感觉有些麻烦

谢谢

弄好之后我给您正确答案，拜托了

fgt258

这个可不会，也不懂你是什么意思，那么宽一页打不完怎么办，你可以录制宏来看看，再修改下试试

真·アムロ

那谢楼上了

真的是很感谢

提了那么多次要求，每次都认真的回复我了

真的是很感激