excel宏教程怎麼用?Sub gg() Dim sh As Worksheet, shname$ ，下面我們就來聊聊關于excel宏教程怎麼用?接下來我們就一起去了解一下吧!

excel宏教程怎麼用

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

通過VBA編程，很容易添加新的工作表，但是新表的名字不知怎樣控制，對于新創建的工作表，由于其名字并非特定，所以就不好使用所創建的新表了不知各位有何高見

Sheets.Add

ActiveSheet.Name = "table"

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

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

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

更多精彩资讯请关注tft每日頭條，我们将持续为您更新最新资讯!