循序渐进VBA EXCEL数据操作小实例

1 向指定单元格区域内写入数据

Sub example1()
    Dim arr(1 To 3)
    arr(1) = Array("A", "B", "C", "D")
    arr(2) = Array("E", "F", "G", "H")
    arr(3) = Array("I", "J", "K", "L")
    For i = 1 To 3
        Range("A" & i & ":D" & i).Value = arr(i)
    Next

End 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 = 1 To 24
        Sheet1.Range("O" & j).Value = j
        
    Next
    
    Row = Sheet1.Range("o65536").End(xlUp).Row '读取数据行行号
    r = r + Row
    
    For k = 1 To r
        Sheet1.Range("P" & k).Value = r
        r = r - 1
    Next
    

    For i = 1 To Row
        arr2 = Sheet1.Range("O" & i & ":P" & i).Value '读取表一指定区域的单元格的值到数组
        Sheets("Sheet1").Range("R" & i & ":S" & i).Value = arr2 '将数组的元素写入到表
        
    Next
    
End Sub

4 Find 及 Findnext 全文查找综合实例

Sub example4()
    Dim s As String
    Dim c
    On Error Resume Next
    'Dim rn
    s = InputBox("输入查找关键字")
    i = 0
  
    Set c = Sheets("sheet1").Range("a1:d65536").Find(s)
    If c Is Nothing Then
       i = 0
    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(232, 254, 250)
        i = i + 1
       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 = 1 To rw
      arr = Sheet1.Range("a" & i & ":d" & i)
      With Sheet2
        .Range("B2") = arr(1, 1)
        .Range("D2") = arr(1, 2)
        .Range("B3") = arr(1, 3)
        .Range("D3") = arr(1, 4)
      End With
      Call printForm '调用打印子程序
    Next
    Call CleanUp '调用清除指定区域数据子程序
End Sub

Sub CleanUp() '清除指定区域数据
    With Sheet2
        .Range("B2").ClearContents
        .Range("D2").ClearContents
        .Range("B3").ClearContents
        .Range("D3").ClearContents
    End With
End Sub

Sub 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 = 1 '设置打印宽度
          .FitToPagesTall = 1 '设置打印高度
      End With
     'ws.PrintOut
      ws.PrintPreview
      End If
    Next

End Sub


Sub 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 < 1 Then rw = 1: End
    i = rw + 1
    
    With Sheet3
        .Cells(i, 1) = xm
        .Cells(i, 2) = nl
        .Cells(i, 3) = zy
        .Cells(i, 4) = zn
    End With
    
    i = i + 1
    Call CleanUp
End Sub

 6 收集指定文件夹下所有工作薄的制定工作表的数据

Sub cldat()

    Application.ScreenUpdating = False
    p = ThisWorkbook.Path & "/"
    f = Dir(p & "*.xlsm")
    Set wb = CreateObject(p & f)
    ThisWorkbook.Sheets(3).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 + 1
        For i = 2 To r
            res = wb.Sheets("sheet3").Range("a" & i & ":d" & i)
            ThisWorkbook.Sheets("sheet3").Range("a" & rr & ":d" & rr) = res
            rr = rr + 1
        Next
    End If
    f = Dir
    Loop While f <> ""
    Set wb = Nothing
    Application.ScreenUpdating = True
End Sub