小男孩‘自慰网亚洲一区二区,亚洲一级在线播放毛片,亚洲中文字幕av每天更新,黄aⅴ永久免费无码,91成人午夜在线精品,色网站免费在线观看,亚洲欧洲wwwww在线观看

搜索
分享

來自【Excel完美論壇】

 周游四方48 2016-07-05
正在加載...
頭像

閬苑小生

2015-1-12 13:37:48

樓主

VBA編程代碼天天有（vba入門學(xué)習(xí)的好資料）

  各位朋友大家好，我是閬苑小生，大家可能已經(jīng)領(lǐng)會到了VBA的強(qiáng)大魅力，想學(xué)習(xí)總感覺有點(diǎn)吃力，我最開始也是如此，感謝有了老師的教導(dǎo)及各位朋友的幫助才使我從一個完全不懂VBA的大菜鳥變成了略知一點(diǎn)皮毛的小菜鳥。為了同大家交流，特開了這個帖子，叫做代碼天天有，是仿照的小老鼠及丫頭兩位老師的叫法，意在每天分享一段自己所寫過的代碼，我認(rèn)為學(xué)習(xí)VBA，練習(xí)寫代碼是蠻重要的。帖子里的代碼絕大部分是自己所寫的，有少部分是學(xué)習(xí)別人的。這些代碼可以說見證了我的成長，不少代碼看起來很幼稚，但是都是自己成長的一部分，對于新手來說都是從簡單代碼入手的，希望能給大家提供一些參考，如果只要有一點(diǎn)能夠?yàn)榇蠹宜茫簿筒煌鏖_這個帖子了！同時也希望大家多多提意見！
    分享的內(nèi)容包括源文件 （供大家測試效果),代碼 （加有注釋），代碼涉及范圍包括常用VBA的知識各大板塊，數(shù)組、字典、正則、自定義函數(shù)、窗體等都包括！代碼1
  1. Sub 插入()'一定要先選中一行
  2. For x = 1 To 500 '從1開始循環(huán) 這里指要重復(fù)進(jìn)行插入動作500次，只是限定了一個次數(shù)而已
  3.     Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove '插入一行 并向下偏移 可錄制宏得到代碼
  4.     ActiveCell.Offset(2, 0).EntireRow.Select '活動單元格向下偏移兩行，然后再選中整行，偏移兩行是為了確保能夠每行都插入
  5.     Next x '可用F8逐步調(diào)試看一下效果
  6. End Sub
  7. Sub 刪除()'首先選中一列
  8.     Selection.SpecialCells(xlCellTypeBlanks).Select '定位 空單元格 等于基礎(chǔ)操作的定位 F5
  9.     Selection.EntireRow.Delete '刪掉空行
  10. End Sub

1-12插入刪除空行
1-13一鍵金額分列
1-14自動匯總數(shù)據(jù)并清除   
1-15刪除任意選中文件夾所有文件的工作表1的第一行
1-16兩種方法匯總多工作表數(shù)據(jù) 
1-17合并任意選擇數(shù)據(jù)
1-18循環(huán)法和find法實(shí)現(xiàn)刪除符合條件整行   
1-19字典實(shí)現(xiàn)簡單的匯總和去重
1-20多行列去重復(fù)值（兩種裝數(shù)組的方法）
1-21兩列去重并求都有的數(shù)據(jù)
1-22字典按多列匯總
1-23字典匯總每個工號對應(yīng)的天數(shù)
1-24 字典匯總并讀出特定條件的數(shù)據(jù)
1-25 字典和冒泡排序最大值
1-26字典盤點(diǎn)商品
1-27按單元格上下空格求和
1-28find的妙用之（月結(jié)對帳）兩列數(shù)字比較染色
1-29將數(shù)據(jù)每200行復(fù)制到新工作表
1-30 按照商品數(shù)量拆分表格
1-31 一列按照條件匯總求和
2-1 按照部門工作表拆分成獨(dú)立的工作薄
2-2 循環(huán)法和find 查找特定格式的數(shù)據(jù)
2-3 利用合并計(jì)算 匯總多工作薄
2-4 按列拆分?jǐn)?shù)據(jù)到目標(biāo)文件夾
2-5 符合條件整行復(fù)制到新表
2-6 對多工作薄多表進(jìn)行拆分
2-7 按類別拆分成獨(dú)立工作表
2-8 VBA法 解決合并單元格動態(tài)填充問題
2-9上下級的乾坤大挪移拆分
2-10split的妙用之兩次拆分
2-11 神奇的按條件著色
2-12 三種方法 提取唯一值
2-13 兩種解法實(shí)現(xiàn)多工作表按條件求和
2-14 匯集多文件夾下特定工作薄的數(shù)據(jù)
2-15 利用字典對年份歸類拆分
2-16 僅對一個單元格內(nèi)的數(shù)字設(shè)置格式
2-17數(shù)組join函數(shù) 標(biāo)示錯題號
2-18 單元格產(chǎn)生祝福滾動字符
2-19 找出三列都有的字符
2-20 自定義求和函數(shù)
2-25 只合并兩列的字母數(shù)字 （正則妙用）
3-4 按編碼每六條記錄形成一個報(bào)告
3-5 將所有價格同時加上10 （正則的使用）
3-7 VBA法 根據(jù)重復(fù)的手機(jī)號提取對應(yīng)的識別碼
3-11 穿插合并 數(shù)據(jù)
3-12 按照填充色 種類求和 （sumif不能實(shí)現(xiàn)的效果）
3-17 VBA正則 提取每行第一個數(shù)字
3-18 vba正則的運(yùn)用 求計(jì)兩個日期之差
3-20 正則 自定義函數(shù) 提取生產(chǎn)編號
3-21 高亮顯示 防止看錯行列
3-22 excel文件打開只能輸入3次密碼
3-23啟用宏才能顯示數(shù)據(jù)
3-24 簡易倒計(jì)時
3-25 快捷考勤輸入
3-26 提取出所有的工作薄、工作表名稱 并添加超鏈接
3-27 單詞翻譯查詢窗體
3-29 工具法做選項(xiàng)卡
感謝大家支持，已停止更新！


立即關(guān)注
308

全部回復(fù)

只看樓主 倒序排列

頭像 閬苑小生 樓主 推薦

  1. Sub 合并計(jì)算()
  2.     Dim path$, wb As Worksheet, arr1(), filename$, k%
  3.     Application.ScreenUpdating = False
  4.     path = ThisWorkbook.path & '\' '取得當(dāng)前工作薄的路徑
  5.     filename = Dir(path & '*.*') '利用dir函數(shù)取得 該文件路徑下的一個工作薄名稱
  6.     Do '利用do loop語句就行循環(huán)
  7.   If filename <> ThisWorkbook.Name Then '不能使它取得當(dāng)前工作薄的名稱不會出現(xiàn)第一個就是工作薄 就退出的情況
  8.   Workbooks.Open path & filename '要合并計(jì)算的工作薄
  9.   k = k 1 '打開一個就記一次數(shù)
  10.   ReDim Preserve arr1(1 To k) '重新定義arr1，arr1是用來最后放完整路徑和數(shù)據(jù)的
  11.   arr1(k) = ''' & path & '[' & filename & ']' & Sheets(1).Name & ''!r1c1:r' & Cells(Rows.Count, 1).End(xlUp).Row & 'c2'
  12.   '每循環(huán)一次，就將完整路徑和數(shù)據(jù)裝入數(shù)組arr1 結(jié)構(gòu)為 完整的路徑 工作薄名 工作表 匯總的數(shù)據(jù)（必須用r1c1引用表示）
  13.   ActiveWorkbook.Close '關(guān)閉活動工作薄，也就是前面循環(huán)打開的工作薄
  14.   End If
  15.   filename = Dir '再一次利用dir取得文件名，這次可以省略后面的路徑
  16.     Loop While filename <> '' '退出do loop語句的條件，不為空
  17.     '=======================以上都是取得所有的數(shù)據(jù)的完整路徑，并裝入一維數(shù)組arr1
  18.     Range('a1').Consolidate arr1, xlSum, True, True '利用合并計(jì)算分類匯總,類似于基礎(chǔ)操作中的合并計(jì)算
  19.     '第一參數(shù)是要計(jì)算的區(qū)域，是一個數(shù)組形式的文本字符串集合
  20.     '第二參數(shù)只合并計(jì)算的類型，這里是求和xlsum，當(dāng)然還有求最值、均值等等
  21.     '第三四參數(shù)指的是是否按首行首列計(jì)算，指是否存在行標(biāo)題和列標(biāo)題
  22.     '第五參數(shù)這里省略，指的是不使用工作表鏈接
  23.     '有興趣的朋友可用F1查看幫助
  24.     Range('a1') = '姓名' '合并計(jì)算的小問題，合并計(jì)算的起始單元格，會是空格，要補(bǔ)上表頭
  25.     Application.ScreenUpdating = True
  26. End Sub
  27. Sub 清空()
  28. Range('a:b').Clear
  29. End Sub<img src='http://www./forum.php?mod=image&aid=1180&size=300x300&key=33752bd53873b58e&nocache=yes&type=fixnone' border='0' aid='attachimg_1180' alt='' style='line-height: 1.5;'>

2015-2-3 22:11:46

頭像 閬苑小生 樓主 推薦

  1. Sub test()
  2.     Dim x, s
  3.     For x = 2 To Cells(Rows.Count, 1).End(xlUp).Row '從第二行開始求和
  4.   s = s Cells(x, 1) '累加求和
  5.   If s > 500 Then Cells(x - 1, 1).Offset(0, 1) = s - Cells(x, 1): x = x - 1: s = 0
  6.   '要求的是求和的不能大于500，則進(jìn)行判斷，如果大于500，則將這個求和結(jié)果s減去這個單元格cells(x,1)的值賦給它上一個單元格的右側(cè)
  7.   '此時x要減去1，繼續(xù)從大于500的那個單元格的上一行循環(huán)，不然的話，會漏掉一行值
  8.   's需要?dú)w零，表示重新疊加求和
  9.   If x = Cells(Rows.Count, 1).End(xlUp).Row Then Cells(x, 2) = s '這個表示將x同最后一行進(jìn)行比較判斷，在前面循環(huán)的時候這一行循環(huán)不到，不管前面是多少，這一行一定有一個匯總的結(jié)果
  10.     Next x
  11. End Sub<img src='http://www./forum.php?mod=image&aid=1065&size=300x300&key=8bbdb523ea6d3520&nocache=yes&type=fixnone' border='0' aid='attachimg_1065' alt='' style='line-height: 1.5;'>

2015-1-31 11:02:02

頭像 閬苑小生 樓主 推薦

  1. Sub 字典和冒泡排序的結(jié)合求最大值()
  2. Dim arr, x&, dic, brr(), k&, rg As Range, t!
  3. t = Timer
  4. Set dic = CreateObject('scripting.dictionary')
  5. arr = Range('a1').CurrentRegion
  6. ReDim brr(1 To UBound(arr), 1 To 4) '定義一個數(shù)組,用來存放結(jié)果，最多數(shù)組arr一樣大
  7. For x = 2 To UBound(arr) '循環(huán)整個數(shù)組區(qū)域
  8.     If Not dic.exists(arr(x, 2)) Then '判斷的依據(jù)是第二列的名稱
  9.   k = k 1
  10.   dic(arr(x, 2)) = k '將k作為條目裝入字典之中
  11.   brr(k, 1) = arr(x, 1)
  12.   brr(k, 2) = arr(x, 2)
  13.   brr(k, 3) = arr(x, 3)
  14.   brr(k, 4) = arr(x, 4)
  15. '=====================上面這是不存在的情況，記一次數(shù)，并把結(jié)果作為條目值裝入字典，用以確定每個名稱在brr中的結(jié)構(gòu)，并把a(bǔ)rr對應(yīng)的結(jié)果裝土brr
  16.   Else
  17.   '=========以下是存在的情況
  18.   If arr(x, 4) > brr(dic(arr(x, 2)), 4) Then '要求找出的是最大值，那么就用第4列的值同brr中已有的值進(jìn)行判斷，如果大于它，則需要把它裝入brr
  19.   '如果小于它，則brr中的已經(jīng)滿足是最大值，不需要動它
  20.   brr(dic(arr(x, 2)), 1) = arr(x, 1)
  21.   brr(dic(arr(x, 2)), 2) = arr(x, 2)
  22.   brr(dic(arr(x, 2)), 3) = arr(x, 3)
  23.   brr(dic(arr(x, 2)), 4) = arr(x, 4) '把最大值的這4列分別裝入到結(jié)果數(shù)組brr之中
  24.   End If
  25.     End If
  26. Next x
  27. On Error Resume Next
  28. Set rg = Application.InputBox('請選擇要存放的區(qū)域所在的起始單元格', '提示', Type:=8) '利用inputbox 選擇存放的其實(shí)單元格
  29. If Err.Number <> 0 Then Exit Sub '這個是在沒有選擇區(qū)域下的情況
  30. rg.Resize(1, 4) = arr
  31. rg.Offset(1, 0).Resize(k, 4) = brr '讀出結(jié)果
  32. rg.Offset(0, 1).Resize(1, 4).EntireColumn.AutoFit
  33. MsgBox Format(Timer - t, '0.00s')
  34. End Sub<img src='http://www./forum.php?mod=image&aid=732&size=300x300&key=bb5efbcf1baf0f94&nocache=yes&type=fixnone' border='0' aid='attachimg_732' alt='' style='line-height: 1.5;'>

2015-1-25 10:41:47

頭像 cnpcwt LV4 推薦

搶沙發(fā)!

2015-2-1 10:18:04

頭像 閬苑小生 樓主 推薦

  1. <span style='line-height: 1.5;'>Private Sub CommandButton1_Click()</span>
  1. Dim arr1, x&, k&, arr2()
  2.     arr1 = Range('a1').CurrentRegion '將數(shù)據(jù)裝入arr1
  3.     For x = 1 To UBound(arr1) '循環(huán)整個數(shù)組
  4.   If arr1(x, 1) = Me.TextBox1.Value Then '如果數(shù)組里的值等于文本框里的值 則計(jì)數(shù)一次
  5.    k = k 1
  6.    ReDim Preserve arr2(1 To k) '重新定義動態(tài)數(shù)組
  7.    arr2(k) = arr1(x, 2) '裝入數(shù)組arr2
  8.   End If
  9.     Next x
  10.     If k = 0 Then MsgBox '單詞不存在': Exit Sub 'k=0 則表明 沒有對應(yīng)的詞組 彈出不存在的對話框
  11.     Me.ListBox1.List = arr2 '將arr2的結(jié)果裝入列表框
  12. End Sub
  13. Private Sub UserForm_Terminate()
  14.     界面.Show '打開窗體界面
  15. End Sub


2015-3-27 16:56:32

頭像 閬苑小生 樓主 推薦

  1. Sub test()
  2.     Dim path$, wbname, x%, y%
  3.     Application.ScreenUpdating = False
  4.     With Application.FileDialog(msoFileDialogFolderPicker) '會彈出一個選擇的對話框
  5.   .Title = '請選擇要顯示的文件夾'
  6.   If .Show = -1 Then
  7.    path = .SelectedItems(1) & IIf(Right(.SelectedItems(1), 1) = '\', '', '\') '等于-1 則表明選擇了一個文件夾
  8.   Else
  9.    Exit Sub '不等于-1 則表明沒有選中文件夾 退出
  10.   End If
  11.     End With
  12.     Sheets.Add '增加一個工作表
  13.     [a1] = '工作薄': [b1] = '工作表' ' 分別寫入 工作薄 工作表 作為標(biāo)示
  14.     wbname = Dir(path & '*.xls*') '取得目標(biāo)文件夾下的excel文件
  15.     Do
  16.     x = ActiveSheet.UsedRange.Rows.Count 1 '取得數(shù)據(jù)區(qū)域行數(shù)的最后一行 并加1
  17.     ActiveSheet.Hyperlinks.Add Cells(x, 1), path & wbname, , wbname, wbname '添加一個超鏈接
  18.     Workbooks.Open path & wbname '打開一個工作薄
  19.     For y = 1 To Sheets.Count
  20.   Workbooks(ThisWorkbook.Name).Sheets(1).Cells(x y, 2) = Sheets(y).Name '將工作表名 裝入到本工作薄的第二列
  21.     Next y
  22.     ActiveWorkbook.Close False '關(guān)閉
  23.     wbname = Dir '再次利用dir取工作薄名
  24.     Loop While wbname <> ''
  25.     Application.ScreenUpdating = True
  26. End Sub

2015-3-26 12:42:40

頭像 晨風(fēng) LV6 推薦

好的,先收藏,感謝分享

2015-3-11 10:59:29

頭像 閬苑小生 樓主 推薦

  1. Sub test()
  2.     Dim reg, arr1, x%, arr2(), k%
  3.     arr1 = Range('a1').CurrentRegion
  4.     ReDim arr2(1 To UBound(arr1), 1 To 1) '定義一個同數(shù)據(jù)源區(qū)域一樣大的數(shù)組arr2
  5.     Set reg = CreateObject('vbscript.regexp') '創(chuàng)建一個正則
  6.     reg.Pattern = '[a-zA-Z]*\d ' '正則的匹配規(guī)則，表示是任意多個字母（從0到n）和至少一個數(shù)字的結(jié)構(gòu)
  7.     For x = 2 To UBound(arr1) '循環(huán)數(shù)組arr1
  8.   k = k 1 '計(jì)數(shù)，作為數(shù)組arr2的結(jié)構(gòu)判斷，也可以直接用x
  9.   arr2(k, 1) = reg.Execute(arr1(x, 4))(0) & '-' & reg.Execute(arr1(x, 5))(0) '把兩列的內(nèi)容分別用正則，由于只有一個合適的結(jié)果，直接取0就可以了
  10.     Next x
  11.     [g2].Resize(k, 1) = arr2 '讀出結(jié)果
  12. End Sub

2015-2-25 10:06:04

頭像 閬苑小生 樓主 推薦

  1. Sub 提取唯一值之刪除重復(fù)項(xiàng)法() '不支持Excel 2003
  2. With Range('c1:d' & Cells(Rows.Count, 1).End(xlUp).Row)
  3.     .Value = Range('a1:b' & Cells(Rows.Count, 1).End(xlUp).Row).Value '將所有信息復(fù)制到C列放置結(jié)果區(qū)域，好對比
  4.     .RemoveDuplicates Array(1, 2), xlYes '提取唯一值，表頭不參與計(jì)算
  5. '===== Range.RemoveDuplicates方法用于刪除區(qū)域中的重復(fù)值，其語法如下：
  6. '=====表達(dá)式.RemoveDuplicates(Columns, Header)
  7. '======第一參數(shù)表示包含重復(fù)信息的列的索引數(shù)組，如果沒有傳遞任何內(nèi)容，則假定所有列都包含重復(fù)信息。
  8. '======第二參數(shù)表示第一行是否包含標(biāo)題信息 可以按F1查看幫助
  9. End With
  10. End Sub
  11. Sub 提取唯一值之高級篩選法()
  12. '對A1到B列最后一個非空單元格執(zhí)行高級篩選，篩選時取唯一值，篩選結(jié)果存放在C1
  13. Range('a1:b' & Cells(Rows.Count, 1).End(xlUp).Row).AdvancedFilter xlFilterCopy, , Range('c1'), True
  14. '表達(dá)式.AdvancedFilter(Action, CriteriaRange, CopyToRange, Unique)
  15. 'Action 必選 XlFilterAction XlFilterAction 的常量之一，用于指定是否就地復(fù)制或篩選列表。
  16. 'CriteriaRange 可選 Variant 條件區(qū)域。如果省略該參數(shù)，則沒有條件限制。
  17. 'CopyToRange 可選 Variant 如果 Action 為 xlFilterCopy，則為復(fù)制行的目標(biāo)區(qū)域。否則，忽略該參數(shù)。
  18. 'Unique 可選 Variant 如果為 True，則只篩選唯一記錄。如果為 False，則篩選符合條件的所有記錄。默認(rèn)值為 False。
  19. End Sub
  20. Sub 提取唯一值之字典法()
  21.     Dim arr, dic, x&, brr, k&
  22.     Set dic = CreateObject('scripting.dictionary')
  23.     arr = Range('a1').CurrentRegion
  24.     ReDim brr(1 To UBound(arr), 1 To 2)
  25.     For x = 1 To UBound(arr)
  26.   If Not dic.exists(arr(x, 1) & arr(x, 2)) Then '將兩列連接起來作為判斷的條件
  27.    k = k 1
  28.    dic(arr(x, 1) & arr(x, 2)) = '' '將它裝入字典
  29.   brr(k, 1) = arr(x, 1)
  30.   brr(k, 2) = arr(x, 2) '不重復(fù)的裝入到結(jié)果數(shù)組brr之中
  31.   End If
  32.     Next x
  33.     [c1].Resize(k, 2) = brr
  34. End Sub
  35. Sub 清空()
  36.     Range('c:d').Clear
  37. End Sub



   經(jīng)過比較，在速度上 三者差別不是很大 幾萬數(shù)據(jù)都是不到0.1秒就可以解決 差別不明顯，在代碼的書寫上 高級篩選和刪除重復(fù)項(xiàng)要簡單的多，主體代碼就一句較為簡單，而字典的代碼相對較長，在實(shí)際運(yùn)用上，高級篩選和刪除重復(fù)項(xiàng)則應(yīng)用相對較為狹窄，只能處理少量的問題，遠(yuǎn)遠(yuǎn)沒有字典功能強(qiáng)大，字典與數(shù)組、正則等的結(jié)合會有強(qiáng)大的威力。強(qiáng)烈建議大家學(xué)習(xí)字典


2015-2-12 10:46:07

頭像 閬苑小生 樓主 推薦

  1. Sub 填充()
  2.     Dim dic, x%, y%, z%, arr
  3.   Range('a3:a1000').Clear
  4.     Application.DisplayAlerts = False '合并單元格會彈窗提示，這個可以關(guān)閉
  5.     Set dic = CreateObject('scripting.dictionary')
  6.     Range('e3:e' & Cells(Rows.Count, 5).End(xlUp).Row).Copy [a3] '現(xiàn)將戶號復(fù)制到第一列
  7.     For x = Cells(Rows.Count, 5).End(xlUp).Row To 3 Step -1 '利用倒循環(huán)的方法
  8.   If Cells(x, 1) = Cells(x - 1, 1) Then
  9.    Range(Cells(x, 1), Cells(x - 1, 1)).Merge '合并單元格的方法
  10.   End If
  11.     Next x
  12.     '===========先將戶號相同的進(jìn)行單元格合并
  13.     For y = 3 To Cells(Rows.Count, 5).End(xlUp).Row
  14.     If Cells(y, 4) = '戶主' Then
  15.   dic(Cells(y, 5).Value) = Cells(y, 3) '利用cells裝入字典的時候一定要加value,不然會默認(rèn)裝入單元格
  16.     End If
  17.     Next y
  18.     '=====將戶號裝入字典之中，并裝入對應(yīng)的姓名，依據(jù)是等于“戶主”的
  19.     For z = 3 To Cells(Rows.Count, 5).End(xlUp).Row
  20.     If Cells(z, 1) <> '' Then Cells(z, 1) = dic(Cells(z, 1).Value) '將戶號替換為戶主姓名，利用字典進(jìn)行反讀條目值，這個類似于vlookup的作用
  21.     Next z
  22. End Sub
  23. Sub 清空()
  24.     Range('a3:a1000').Clear
  25. End Sub

    本站是提供個人知識管理的網(wǎng)絡(luò)存儲空間，所有內(nèi)容均由用戶發(fā)布，不代表本站觀點(diǎn)。請注意甄別內(nèi)容中的聯(lián)系方式、誘導(dǎo)購買等信息，謹(jǐn)防詐騙。如發(fā)現(xiàn)有害或侵權(quán)內(nèi)容，請點(diǎn)擊一鍵舉報(bào)。
    轉(zhuǎn)藏 分享 獻(xiàn)花（0）

    0條評論

    發(fā)表

    請遵守用戶 評論公約

    類似文章 更多