十年前初学VBA逐个验证的小代码

Sub 宏1()

Dim i As Long

For i = 1 To 10

Cells(i, 3) = Cells(i, 1).Value & "-" & Cells(i, 2).Value

Next

End Sub

Sub 宏1()

Dim arr '声明一个变量

Dim x As Integer

arr = Range("a1:d10") '确定arr的范围，也就是我们操作的区域

For x = 1 To 7

arr(x, 4) = arr(x, 3) * arr(x, 2) '数组的赋值方法

Next x

Range("a1:d4") = arr '数组最终的赋值区域，区域不同结果不同，但不能超出前面定义的范围

End Sub

Sub 宏1()

Dim arr(1 To 5) '声明一个变量,固定数组A1到E1

For x = 1 To 5

arr(x) = x * 3 '声明单个单元格的计算方法

Next x

Range("a1:e1") = arr '把单元格计算的结果赋值给我们选定的数组

Range("a1:a5") = Application.Transpose(arr) '把我们选定的数组做转置，出结果A1到A5

End Sub

Sub ggsmart()

Dim i%, xrow%, j%, xcount% '定义变量xrow为A列单元格数目，xcount为包含张的个数

Dim arr() As String '定义arr为动态数组，由于不确定动态数组的边界

xrow = [a65536].End(3).Row '算出A列最后一个非空单元格行号然后赋值给Xrow

j = 1 '数组索引号

xcount = Application.WorksheetFunction.CountIf([a1:a65536], "张*") '统计有多少姓张的学生赋值给xcount

ReDim arr(1 To xcount) '重新定义数组大小，元素共有xcount个，此时xcount已经有值了

For i = 1 To xrow '定义i的取值范围

If Left(Cells(i, 1).Value, 1) = "张" Then

arr(j) = Cells(i, 1).Value '给数组中各个元素赋值

j = j 1 '索引号加1

End If

Next i

[b1:b65536].Clear '清除原有数据

[b1].Resize(1, xcount) = arr '对B1往右的xcount个单元格输入数组的值

[b1].Resize(xcount, 1) = Application.WorksheetFunction.Transpose(arr) '对B1往下的xcount个单元格输入数组的值

End Sub

Sub test()

Dim arr, arr1(1 To 10000, 1 To 1)

Dim x, m, k

arr = Range("a1:a21")

For x = 1 To UBound(arr)

If arr(x, 1) <> "" Then

k = k 1

arr1(k, 1) = arr(x, 1)

Else

m = m 1

Range("b1").Offset(0, m).Resize(k) = arr1

Erase arr1

k = 0

End If

Next x

End Sub

Sub test()

Dim arr, x

arr = Range("a1:d6")

For x = 1 To UBound(arr)

arr(x, 1) = arr(x, 1) * 3

arr(x, 2) = arr(x, 1) * 3

arr(x, 3) = arr(x, 1) * arr(x, 2)

arr(x, 4) = arr(x, 3) * arr(x, 2)

Next x

Range("a8:d13") = arr

End Sub

Sub t() ’（字典装入数字）

Dim d

Dim arr

Dim x As Long

Set d = CreateObject("scripting.dictionary")

For x = 1 To 6

d.Add Cells(x, 1).Value, Cells(x, 2).Value’这种装入只能在KEYS列装入非重复的

Next x

Range("d1").Resize(d.Count) = Application.Transpose(d.keys)

Range("e1").Resize(d.Count) = Application.Transpose(d.items)

End Sub

Sub rr()

Dim d

Dim arr

Dim x As Long

arr = Range("a1:b16")

Set d = CreateObject("scripting.dictionary")

For x = 1 To 16

d(arr(x, 1)) = d(arr(x, 1)) arr(x, 2)’这种修改的方法最常用，可以删除重复值，单条件汇总

Next x

Range("d1").Resize(d.Count) = Application.Transpose(d.keys)

Range("e1").Resize(d.Count) = Application.Transpose(d.items)

End Sub

Sub 提取所有工作表名称()

For x = 1 To Sheets.Count

Cells(x, 7) = Sheets(x).Name

Next x

End Sub

Sub te()

Dim Arr1

On Error Resume Next

Application.DisplayAlerts = False

Arr1 = Range(Cells(1, 3), Cells(Cells(65536, 3).End(xlUp).Row, 3))’指定arr1内的名字将其删除

For Each i In Arr1

Sheets(i).Delete

Next

Application.DisplayAlerts = True

End Sub

Sub 创建工作表()

Dim i As Integer

i = 2

Do While Sheets(1).Cells(i, 1) <> ""

Sheets.Add after:=Sheets(Sheets.Count)

ActiveSheet.Name = Sheets(1).Cells(i, 1)

i = i 1

Loop

End Sub

Sub tt()

For i = 1 To ActiveWorkbook.Worksheets.Count

ActiveWorkbook.Worksheets(i).Cells(1, 1).Value = "a"

Next

End Sub

关于这个问题本文分享两段VBA代码，都可实现该功能，以判断单元格中是否包含”?”为例，具体代码如下。

1. If cells(1,1) Like “*?*” Then
   2. If InStr(1, cells(1,1), “?”) = 0 Then
   用VBA判断EXCEL元素是否包含特定字符的情况较为常用，且多放在循环语句中，从运行效率来讲，第二种方法优于第一种，当然，如果把所有cells里的信息，在第一时间都抓到内存中，运行速度会更快。

Sub test()

Dim x As Long

Dim y As Integer

Dim tt As Single

tt = Timer

For x = 4 To 2000 Step 3

For y = 1 To Int(x / 3)

Cells(x, 1).Resize(3, 1) = Cells(1, 1) y

Next y

Next x

MsgBox "ok,用时" & Timer - tt & "秒!"

End Sub

Sub Macro1()
Dim n As Long
n = Range("a65536").End(xlUp).Row
For i = n - 1 To 1 Step -1
Cells(i 1, 1).EntireRow.Insert Shift:=xlDown
Next
End Sub

Sub Macro2()

Dim n As Long

n = Range("a65536").End(xlUp).Row

For i = n 1 To 2 Step -2

Rows(i & ":" & i 2).Insert

Next

End Sub

Sub aa()

maxh = Sheet1.Range("a65536").End(3).Row

Range("a1:a" & maxh).SpecialCells(xlCellTypeBlanks).select

selection.entirerow.delete

End Sub

Sub test()

Dim begin As Integer

Dim endValue As Integer

Dim jg As Integer

begin = 3 '开始行

endValue = 493 '结束行

jg = 1 '间隔 '千万不要以为是2，因为当第3行被删除后，第5行已经变成了第4行

Dim i As Integer

For i = begin To endValue Step jg

Range("A" & i).EntireRow.Delete

Next i

End Sub

1. 注：Range("A1").EntireColumn.Delete 这样是删除A1整列
2. Range("A1").EntireRow.Delete 这样是删除A1整行
3. Range("A1").Delete 这是删除A1单元格 A2单元格会移上去
4. 上述命令就好像 你选中A1单元格后，右击选择 -》删除 ，在弹出对话框中有四个选项
5. 
   

Public Sub delete()

Dim i As Integer, j As Integer

j = Worksheets.Count

For i = 1 To j

Sheets(i).Rows("2:5").delete Shift:=xlUp

Next

End Sub

Sub delete()

Dim y As Long

y = Sheets.Count

For s = 2 To y

For x = 1 To Sheets(1).[a65536].End(3).Row

For i = 1 To Sheets(s).[j65536].End(3).Row

If Sheets(s).Cells(i, 10) = Sheets(1).Cells(x, 1) Then 'Sheets(i).属性(方法) 中的i指的不是你为工作表标签设置的名称.指的是工作表在当前工作薄中的序号.

Sheets(s).Rows(i).delete

End If

Next i

Next x

Next s

End Sub

（根据sheets1A列单元格的值在其他sheets里面找到对应单元格的值的行删除）

Sub r()

Dim arr, arr1()

Dim x As Integer

arr = Range("a1:a10")

m = Application.CountIf(Range("a1:a10"), ">10")

ReDim arr1(1 To m)

For x = 1 To 10

If arr(x, 1) > 10 Then

k = k 1

arr1(k) = arr(x, 1)

End If

Next x

Cells(1, 2).Resize(m, 1) = Application.WorksheetFunction.Transpose(arr1)

End Sub

Sub hebing()

a = ""

For i = 1 To Range("A65536").End(xlUp).Row 1

If Cells(i, 1) = "" Then

Range("C" & i 1 & ":C" & Range("A" & i 1).End(xlDown).Row).Merge

Cells(Range("A" & i - 1).End(xlUp).Row, 3) = a

a = ""

Else

If a = "" Then

a = Cells(i, 1)

Else

a = a & Cells(i, 1)

End If

End If

Next

End Sub