|
|
YEJINHAI 发表于 2012-7-26 21:13 
我觉得有一段代码好像出错了。
其中一段代码应该是这样吧？
Set Ash = ActiveSheet
对不起。我轻轻改了一下代码。看看这样是否更适合？
Private Sub UserForm_Initialize()
ScrollBar1.Max = Columns.Count
ScrollBar2.Max = Columns.Count
ScrollBar3.Max = Columns.Count
ScrollBar4.Max = Columns.Count
ScrollBar5.Max = 12
ScrollBar6.Max = 20
'--------------------------------
TextBox1.Text = 2 '开始行号
TextBox2.Text = 2 '标题行数
TextBox3.Text = 1 '每组人数
TextBox4.Text = 0 '间隔行数
TextBox5.Text = Month(Now) - 1 '打印月份
TextBox6.Text = 12
If TextBox1.Text > 0 Then ScrollBar1.Value = TextBox1.Text
If TextBox2.Text > 0 Then ScrollBar2.Value = TextBox2.Text
If TextBox3.Text > 0 Then ScrollBar3.Value = TextBox3.Text
If TextBox4.Text > 0 Then ScrollBar4.Value = TextBox4.Text
If TextBox5.Text > 0 Then ScrollBar5.Value = TextBox5.Text
If TextBox6.Text > 0 Then ScrollBar6.Value = TextBox6.Text
End Sub
Private Sub ScrollBar1_Change() '开始行号
TextBox1.Text = ScrollBar1.Value
End Sub
Private Sub ScrollBar2_Change() '标题行数
TextBox2.Text = ScrollBar2.Value
End Sub
Private Sub ScrollBar3_Change() '每组人数
TextBox3.Text = ScrollBar3.Value
End Sub
Private Sub ScrollBar4_Change() '间隔行数
TextBox4.Text = ScrollBar4.Value
End Sub
Private Sub ScrollBar5_Change() '存放行号
TextBox5.Text = ScrollBar5.Value
End Sub
Private Sub ScrollBar6_Change() '存放行号
TextBox6.Text = ScrollBar6.Value
End Sub
Private Sub CommandButton1_Click()
Dim Ash As Worksheet, sh As Worksheet, hq, hz, lq, lz, ih, il
Dim ks, bt, rs, jg, yf, yrs
Dim I, j, k
Dim BtCopy As Range, IRng As Range, IName, N
On Error Resume Next
On Error GoTo 0
With Me
ks = Val(.TextBox1.Text)
bt = Val(.TextBox2.Text)
rs = Val(.TextBox3.Text)
jg = Val(.TextBox4.Text)
yf = Val(.TextBox5.Text)
yrs = Val(.TextBox6.Text)
Unload Me 'Me.Hide
End With
Application.EnableEvents = False
'Application.ScreenUpdating = False
Application.Calculation = xlManual 'Application.Calculation = xlAutomatic
Set Ash = ActiveSheet
IName = "(IName)"
Application.DisplayAlerts = False
For Each ws In Worksheets
If ws.Name Like "*IN*" Then
ws.Delete
End If
Next
Set ws = Nothing
Application.DisplayAlerts = True
Ash.Copy Before:=Ash
Set sh = ActiveSheet
sh.Name = IName
With sh
.Activate
hq = ks + bt
lq = 1
lz = Cells(hq, Columns.Count).End(xlToLeft).Column
hz = Cells(Rows.Count, 2).End(xlUp).Row
Set BtCopy = Rows(ks).Resize(bt)
Set IRng = Range(Cells(hq, lq), Cells(hz, lz))
IRng.MergeCells = False '取消合併
IRng.Copy
IRng.PasteSpecial Paste:=xlPasteValues
IRng.ShrinkToFit = True '自動縮小字體
IRng.Interior.ColorIndex = xlNone '清空填充色
If CheckBox1 Then Range(Cells(hq, lq), Cells(hz, lq)).Value = yf
Set IRng = Nothing
Application.CutCopyMode = False
.DrawingObjects.Delete '清理對象
.ResetAllPageBreaks '重置分頁符
.DisplayAutomaticPageBreaks = False '取消自動分頁符
.PageSetup.BlackAndWhite = False '設置一頁寬
With .PageSetup
.PaperSize = xlPaperA4
.FitToPagesWide = 1 '頁寬
'.FitToPagesTall =1 '頁高
End With
End With
N = IIf(rs <= 0, 1, rs)
For I = hq To hz Step IIf(rs <= 0, 1, rs)
k = k + 1
If I = hz Then GoTo q
BtCopy.Copy
Rows(I + N).Insert Shift:=xlDown
Application.CutCopyMode = False
Rows(I + N).Activate
If jg > 0 Then
With Rows(I + N).Resize(jg)
Rows(Rows.Count - 1).Copy
.Insert Shift:=xlDown '插入間隔
.Offset(-jg, 0).RowHeight = 2.5 '默認行高
Application.CutCopyMode = False
End With
N = N + jg
End If
If k Mod yrs = 0 Then
'本示例在单元格上方添加水平分页符，在其左方添加垂直分页符。
With sh
ActiveWindow.View = xlPageBreakPreview '分頁視圖
.HPageBreaks.Add Before:=.Cells(I + N, lq)
.VPageBreaks.Add Before:=.Cells(I + N, lz)
ActiveWindow.View = xlNormalView '普通視圖
End With
End If
N = N + BtCopy.Rows.Count
Next I
q:
Application.EnableEvents = True
Application.ScreenUpdating = True
Application.Calculation = xlAutomatic 'Application.Calculation = xlManual
End Sub
'------------ 判断工作表是否存在如果存在的附加函数：
Function SheetExists(SheetName As String) As Boolean
SheetExists = False
On Error GoTo NoSuchSheet
If Len(Sheets(SheetName).Name) > 0 Then
SheetExists = True
Exit Function
End If
NoSuchSheet:
End Function
|
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2012-7-26 17:31
该贴已经同步到 
楼主
