1 向指定单元格区域内写入数据
Sub example1()
Dim arr( To )
arr() = Array("A", "B", "C", "D")
arr() = Array("E", "F", "G", "H")
arr() = Array("I", "J", "K", "L")
For i = To
Range("A" & i & ":D" & i).Value = arr(i)
NextEnd Sub
2 复制指定单元格内的数据到另一个区域
Sub example2()
Dim arr1
arr1 = Range("A1:D1").Value
Range("G3:J3").Value = arr1
End Sub
3 数据操作综合实例
Sub example3()
Dim i As Integer
Dim Tit
Tit = Array("正序列", "倒序")
Sheet1.Range("O1:P1").Value = Tit For j = To
Sheet1.Range("O" & j).Value = j Next Row = Sheet1.Range("o65536").End(xlUp).Row '读取数据行行号
r = r + Row For k = To r
Sheet1.Range("P" & k).Value = r
r = r -
Next For i = To Row
arr2 = Sheet1.Range("O" & i & ":P" & i).Value '读取表一指定区域的单元格的值到数组
Sheets("Sheet1").Range("R" & i & ":S" & i).Value = arr2 '将数组的元素写入到表 NextEnd Sub
4 Find 及 Findnext 全文查找综合实例
Sub example4()
Dim s As String
Dim c
On Error Resume Next
'Dim rn
s = InputBox("输入查找关键字")
i = Set c = Sheets("sheet1").Range("a1:d65536").Find(s)
If c Is Nothing Then
i =
Else
firstAddress = c.Address
r = Sheet1.Range("a65536").End(xlUp).Row
Do
Set c = Sheet1.Range("a1:d" & r).FindNext(c)
c.Interior.Color = RGB(, , )
i = i +
Loop While Not c Is Nothing And c.Address <> firstAddress End If MsgBox "共有" & i & "条满足条件的记录."
End Sub
5 添加数据及数据套打综合实例
Sub example5()
rw = Sheet1.Range("a65536").End(xlUp).Row
For i = To rw
arr = Sheet1.Range("a" & i & ":d" & i)
With Sheet2
.Range("B2") = arr(, )
.Range("D2") = arr(, )
.Range("B3") = arr(, )
.Range("D3") = arr(, )
End With
Call printForm '调用打印子程序
Next
Call CleanUp '调用清除指定区域数据子程序
End SubSub CleanUp() '清除指定区域数据
With Sheet2
.Range("B2").ClearContents
.Range("D2").ClearContents
.Range("B3").ClearContents
.Range("D3").ClearContents
End With
End SubSub printForm() '打印
Dim ws As Worksheet
For Each ws In Worksheets
If (ws.Visible = xlSheetVisible) And (ws.Name = "Sheet2") Then
With ws.PageSetup
.Zoom = False '关闭打印缩放 .FitToPagesWide = '设置打印宽度
.FitToPagesTall = '设置打印高度
End With
'ws.PrintOut
ws.PrintPreview
End If
NextEnd SubSub example6() '添加信息
Dim xm$, nl$, zy$, zn$ '声明数据类型为字符串
xm = Sheet2.Range("b2").Value
nl = Sheet2.Range("d2").Value
zy = Sheet2.Range("b3").Value
zn = Sheet2.Range("d3").Value rw = Sheet3.Range("a65536").End(xlUp).Row
If rw < Then rw = : End
i = rw + With Sheet3
.Cells(i, ) = xm
.Cells(i, ) = nl
.Cells(i, ) = zy
.Cells(i, ) = zn
End With i = i +
Call CleanUp
End Sub
6 收集指定文件夹下所有工作薄的制定工作表的数据
Sub cldat() Application.ScreenUpdating = False
p = ThisWorkbook.Path & "/"
f = Dir(p & "*.xlsm")
Set wb = CreateObject(p & f)
ThisWorkbook.Sheets().Range("a2:d65536").ClearContents
Do
If f <> ThisWorkbook.Name Then
r = wb.Sheets("sheet3").Range("a65536").End(xlUp).Row
rr = ThisWorkbook.Sheets("sheet3").Range("a65536").End(xlUp).Row +
For i = To r
res = wb.Sheets("sheet3").Range("a" & i & ":d" & i)
ThisWorkbook.Sheets("sheet3").Range("a" & rr & ":d" & rr) = res
rr = rr +
Next
End If
f = Dir
Loop While f <> ""
Set wb = Nothing
Application.ScreenUpdating = True
End Sub