返回目录：excel表格制作
1、 我想运行一个宏,就能在当前工作表B3上填上一条公式;这条公式的结果是所有工作 表上的B4单元格的和.请问这个宏该如何写
Sub gg()
Dim sh As Worksheet, shname$
For Each sh In Worksheets
shname = sh.Name
ActiveSheet.Range("b3").value = ActiveSheet.Range("b3").value + Worksheets(shname).Range("b4")
Next
End Sub
2、 VBA中怎样创建一个名为“table”的新工作表
通过VBA编程，很容易添加新的工作表，但是新表的名字不知怎样控制，对于新创建的工作表，由于其名字并非特定，所以就不好使用所创建的新表了不知各位有何高见
Sheets.Add
ActiveSheet.Name = "table"
3、 如何用VBA检索表1中A列与表2，3，4，5.....中A列相同的行并把后者整行拷贝到表1检索到的行中
Sub Copy1()
Dim Row_dn1, Row_dnN, i, j, n As Integer
Row_dn1 = Sheet1.Range("A65536").End(xlUp).Row
k = 1: n = 1
For Each wSheet In ActiveWorkbook.Worksheets
With wSheet
If .Name <> "Sheet1" Then
Row_dnN = .Range("A65536").End(xlUp).Row
For i = 2 To Row_dn1
For j = 2 To Row_dnN
If .Cells(j, 1) = Sheet1.Cells(i, 1) Then
.Rows(j & ":" & j).Copy Destination:=Sheet1.Rows(Row_dn1 + n & ":" & Row_dn1 + n)
n = n + 1
End If
Next j
Next i
End If
End With
Next wSheet
End Sub
4、 如果要用VBA程式输入密码使用下列程式码
Sub EnterNewPW()
'程式说明:利用SendKey输入VBAProject密码
'注意事项:执行本程式需要在Excel视窗,不能在VBE视窗
Application.SendKeys "%{F11}", True 'Alt + F11 切换到VBA视窗
Application.SendKeys "%T", True 'ALT + T 工具(繁体中文是(T))
Application.SendKeys "e", True '工具(T)-VBproject属性(E)
Application.SendKeys "^{TAB}", True 'TAB 键(切换到PAge2 保护页面)
Application.SendKeys "{+}", True '选取Checkbox方块(锁定专案以供检视) ({+} 选取, {-} 取消选取)
Application.SendKeys "{TAB}", True 'TAB 键(跳到第一次输入密码 Textbox
myPW = "chijanzen" '假设密码 chijanzen
Application.SendKeys myPW, True'输入密码
Application.SendKeys "{TAB}", True 'TAB 键(跳到第二次输入密码 Textbox
Application.SendKeys myPW, True '输入密码
Application.SendKeys "{ENTER}", True '按确定钮(预设值)
Application.SendKeys "%{F11}", True '返回Excel视窗
End Sub
5、 冒泡排序法之所以成为“冒泡排序”是因为值较小的或是较轻的元素浮到作为继续排序的一组数的顶部
Sub Macro1()
Dim i As Integer
Dim j As Integer
Dim t as integer
Static number(1 To 10) As Integer
For i = 1 To 10
number(i) = inputbox“输入要排序的数：”
Next i
For i = 10To 2 Step -1
For j = 1 To i – 1
‘下面进行位置交换
If number(j) > number(j + 1) Then
t = number(j + 1)
number(j + 1) = number(j)
number(j) = t
End If
Next j
Next i
For i = 1 To 20
Print number(i)
Next i
End sub
首先定义一个数组：通过循环录入10个整数，然后用一个二重循环测试前一个数是否大于后一个数如果大于则交换两个数的下标，即交换两个数在数组中的位置，交换通过一个变量来进行
我先用传统的方法解决这个问题，经过比较，选用了较为简单的和高效的排序方法
——“快速排序”，具体算法可参考数据结构等有关书籍对所有数据排序后再合
并相同数据，合并程序较为简便，我开始时采用了这种方法，但后来发现对于这些
的数据，先合并后排序速度更快，因为有大量相同的数据合并是采用“标记”算
法，具体如下：（设数据已存放在sData()数组中 ，结果存到Queryp()数组，
Amount是数据个数）
'把相同元素置 0
For i = 1 To Amount
If sData(i) <> 0 Then
For j = i ＋ 1 To Amount
If sData(i) = sData(j) Then sData(j) = 0
Next j
End If
Next i
'删除相同元素
Queryp(1) = sData(1)
k = 1
For i = 2 To Amount
If Not (sData(i) = 0) Then
k = k ＋ 1
Queryp(k) = sData(i)
End If
Next i
kMax = k
ReDim Preserve Queryp(kMax)
虽然这样使得运算速度有所高，但是仍然要进行大量的循环运算，占据了程序大部
分的运算时间于是我一直在寻觅一种更为高效的算法
功夫不负有心人，在仔细分析数据的特征，比较了多种方案之后，我终于找到了一
种相当成功的算法，原来要3到4秒的运算缩短到仅需0.1到0.2秒
我遇到的数据具有以下特征：①相同数据很多，②最大、最小数之间相差不到3，
③都是带两位小数的正数
针对数据的特征，我采用了以下算法：
针对数据的特征，我采用了以下算法：
步骤：
1． 用一个循环找出整数和小数部分的最大、最小值小数部分的最大、最小值乘
以100转为整数
2． 定义一个二维数组，下标范围分别是整数和小数部分的最小值到最大值
3． 再用一个循环把所有源数据填入刚才定义的二维数组，填写规则是，源数据的
整数和小数部分分别对应二维数组的两个下标例如，“13.51"填到“A(13,51)"
中
4． 最后顺向或逆向读取二维数组中的非零数据即可得到从小到大或从大到小排列
的数据，而且不会含有重复数据
用VB 编写的程序如下：
'＊＊＊＊密集型数据处理＊＊＊＊
Dim i As Long, j As Long, k As Long, kMax As Long
Dim Queryp() As Single
ReDim Queryp(Amount)
Dim IntegerPart As Integer, DecimalPart As Integer
Dim IPmax As Integer, IPmin As Integer
Dim DPmax As Integer, DPmin As Integer
Dim DiffDataArray()
'读取数据
ReadData
IPmax = 0: IPmin = 1000
DPmax = 0: DPmin = 99
For i = 1 To Amount
' 找整数和小数部分的最大、最小值
IntegerPart = Int(sData(i))
DecimalPart = (sData(i) － IntegerPart) ＊ 100
If IntegerPart > IPmax Then
IPmax = IntegerPart
ElseIf IntegerPart < IPmin Then
IPmin = IntegerPart
End If
If DecimalPart > DPmax Then
DPmax = DecimalPart
ElseIf DecimalPart < DPmin Then
DPmin = DecimalPart
End If
Next i
ReDim DiffDataArray(IPmin To IPmax, DPmin To DPmax)
'填入数据
For i = 1 To Amount
IntegerPart = Int(sData(i))
DecimalPart = (sData(i) － IntegerPart) ＊ 100
DiffDataArray(IntegerPart, DecimalPart) = sData(i)
Next i
Next i
'提取数据
k = 0
For i = IPmax To IPmin Step －1
For j = DPmax To DPmin Step －1
If DiffDataArray(i, j) <> 0 Then
k = k ＋ 1
Queryp(k) = DiffDataArray(i, j)
End If
Next j
Next i
kMax = k
ReDim Preserve Queryp(kMax)
该方法对于本人遇到的这种“密集型”数据最为有效，但是如果遇上“稀疏型”数
据，例如最大、最小值相差几千，甚至上万的数据，就没什么优势了，而且会占用
较大的内存
经过改进，我得到了处理稀疏型数据的高效算法高效的前提条件同样是源数据具
有大量相同数据思路是在前一种方法的基础上增加一个单维数组，用来保存整数
部分数据，保存过程中用插入法对其进行排序因为有大量重复数据，要排序的数
据量相对较少当从二维数组中读取数据时，用单维数组代入二维数组的第一个下
标，具体代码下：
'＊＊＊＊稀疏型数据处理＊＊＊＊
Dim i As Long, j As Long, k As Long, kMax As Long
Dim Queryp() As Single
ReDim Queryp(Amount)
Dim IntegerPart As Integer, DecimalPart As Integer
Dim IPmax As Integer, IPmin As Integer
Dim DPmax As Integer, DPmin As Integer
Dim IPArray() As Integer, IPAamount As Integer
ReDim IPArray(Amount)
Dim DiffDataArray()
'读取数据
ReadData
IPmax = 0: IPmin = 1000
DPmax = 0: DPmin = 99
IPAamount = 0
For i = 1 To Amount
'获取整数和小数部分的最大最小值
IntegerPart = Int(sData(i))
DecimalPart = (sData(i) － IntegerPart) ＊ 100
If IntegerPart > IPmax Then
IPmax = IntegerPart
ElseIf IntegerPart < IPmin Then
IPmin = IntegerPart
IPmin = IntegerPart
End If
If DecimalPart > DPmax Then
DPmax = DecimalPart
ElseIf DecimalPart < DPmin Then
DPmin = DecimalPart
End If
'对整数部分"IPArray()"进行插入法排序 (从大到小）
For j = 1 To IPAamount
If IntegerPart > IPArray(j) Then
IPAamount = IPAamount ＋ 1
For k = IPAamount To j ＋ 1 Step －1
IPArray(k) = IPArray(k － 1)
Next k
IPArray(j) = IntegerPart
Exit For
ElseIf IntegerPart = IPArray(j) Then
Exit For
End If
Next j
If j > IPAamount Then
IPAamount = IPAamount ＋ 1
IPArray(IPAamount) = IntegerPart
End If
Next i
ReDim DiffDataArray(IPmin To IPmax, DPmin To DPmax)
'填入数据
For i = 1 To Amount
IntegerPart = Int(sData(i))
DecimalPart = (sData(i) － IntegerPart) ＊ 100
DiffDataArray(IntegerPart, DecimalPart) = sData(i)
Next i
'提取数据
k = 0
For i = 1 To IPAamount
For j = DPmax To DPmin Step －1
If DiffDataArray(IPArray(i), j) <> 0 Then
k = k ＋ 1
Queryp(k) = DiffDataArray(IPArray
（i), j)
End If
Next j
Next i
kMax = k
ReDim Preserve Queryp(kMax)
k
ReDim Preserve Queryp(kMax)
具体采用哪种算法，要看数据的性质而定，以下是本人的一些实测数据，仅供参考
如果你有更好的方法，可不要忘记和朋友们分享哦
自动隐藏表格中无数据的行
表1 是数据源，经常改变；
表2 引用表1 中某列有数据的单元格（利用动态位址已实现）
由于表1 的改变，表2 的大小随之而变
问题：如何实现表2 中没有数据的行（有公式）自动隐藏？谢谢赐教！
Sub abc()
For i = 1 To 300
If Cells(i, 1).value = "" Then Rows(i).Hidden = True
Next i
End Sub
你写的语句可以解决隐藏的问题，可是如果我执行了它之后，再在表1中增加数据，表2不会自动显示有了数据的行如何修改？
将此宏设为自动运行（打开文件时）
Sub abc()
For i = 1 To 300
If Cells(i, 1).value <>"" Then Rows(i).Hidden = false
Next i
End Sub
用VBA如何自动合并列的内容？
用VBA如何自动合并列的内容？
To hongjian ：
Sub MergeTest()
For i = 3 To 30
Cells(i, 3) = Cells(i, 1) & Chr(10) & Cells(i, 2)
Next
End Sub