一个宏文件vba

Sub Revenue_LOAD()
'
' DSO_Revenue 宏

'
Msg = MsgBox("LOAD Revenue" & vbNewLine & vbNewLine & "This process will guide you to load Revenue provided by BI" _
& vbNewLine & "this tool step by step, and current Revenue will be erased completely." & vbNewLine & vbNewLine & "Do you want to continue?" & vbNewLine _
& vbNewLine & "-------------------------------------------------------------------------" _
& vbNewLine _
& vbNewLine & "Step 1:  Choose the file contains Revenue from window popped up;" _
& vbNewLine & "Step 2:  Input the target table name which contains Revenue into dialog" _
& vbNewLine & "              box popped up;" _
& vbNewLine & "Step 3:  Please check the accuracy of Revenue loaded." _
, vbYesNo, "WARNING")

      If Msg = vbNo Then '否按钮被单击

         ThisWorkbook.Worksheets("From Pact V1").Activate

         Exit Sub

       End If

'---------------------------------------------------------------Define Variable---------------------------------------------------------------

Dim xRow As Long
Dim yRow As Long
Dim TarFile, TarTab As String
Dim TarWb As Workbook
Dim tarRange, myRange As Range
Dim DSO As Worksheet

Set Revenue = ThisWorkbook.Worksheets("From Pact V1")

'---------------------------------------------------------------Open DSO Source---------------------------------------------------------------

TarFile = Application.GetOpenFilename 'GetOpenFilename相当于Excel打开窗口，通过该窗口选择要打开的文件，并可以返回选择的文件完整路径和文件名

MsgBox "Revenue path: " & TarFile

If TarFile = "False" Then '如果点击了取消，返回false

   Revenue.Activate

   Exit Sub

End If

'----------------------------------------当发生错误时--------------------------------------------

On Error Resume Next '发生错误时 让程序继续执行下一句代码


Set TarWb = Workbooks.Open(TarFile) '打开刚才选择的那个文件

On Error Resume Next '发生错误时 让程序继续执行下一句代码


TarTab = Application.InputBox(prompt:="Please input the name of your target table here" _
& " ", Title:="DATA SELECTION", Type:=2) 'application.inputbox在输入字符串后点击“确认”按钮根据type类型返回不同点击“取消”则返回逻辑type为 0 返回文本，type为1返回数字 type为2返回公式  ，4 逻辑值 8单元格引用 16错误值值false类型的值

If TarWb.Worksheets(TarTab) Is Nothing Then '如果输入的table无内容，则执行下面代码块

   MsgBox "Please input a valid worksheet name! for example 'Sheet1'"""

   DSO.Activate '使这个表为当前活跃的工作表，相当于鼠标点击选择了此表
   TarWb.Close SaveChanges:=False '关闭不保存
   Exit Sub

End If

'------------------------------------------探空如果有值就赋值对应给xRow和tarRange------------------------------------------

On Error Resume Next

xRow = TarWb.Worksheets(TarTab).Range("A20000").End(xlUp).Row
'把上一步手动输入的那个表end(xlup)向上非空单元格 .row 行号 向上数简单理解A列最后一个有数据的单元所在的行数

MsgBox "Count of SubData line is going to be loaded >>> " & xRow & ""

Set tarRange = TarWb.Worksheets(TarTab).Range("A2:C" & xRow) ' "c"的第xRow列如A2:C12435

If tarRange Is Nothing Then '如果这个区域是空的进行里面这个代码块

   Revenue.Activate
   TarWb.Close SaveChanges:=False
   Exit Sub

End If


'---------------------------------------------------------------Show All Data---------------------------------------------------------------
On Error Resume Next

Revenue.Unprotect Password:="XXXXXX" 'Excel 表格密护的方法

Revenue.ShowAllData '使当前筛选列表的所有行均可见

'---------------------------------------------------------------Erase Old Data-擦除去老数据--------------------------------------------------------------

Application.ScreenUpdating = False '如果屏幕更新已启用，此属性的值为 True
'关闭屏幕更新可加快宏的执行速度。这样将看不到宏的执行过程，但宏的执行速度加快了。
'当宏结束运行后，请记住将 ScreenUpdating 属性设置回 True。
Application.Calculation = xlCalculationManual 'calculation是指手动计算还是自动计算。
'处理大数据量时，为了更快的运行，VBA通常在开始加两句即上两句话是常用的模版处理，有开始有关闭一定要成对出现


yRow = Revenue.Range("A20000").End(xlUp).Row

Revenue.Range("A2:AB" & yRow + 2).ClearContents '清理区域中的公式和值。

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
'对应上面开始

'---------------------------------------------------------------Copy DSO 1-3 to DSO Tool---------------------------------------------------------------

Set myRange = ThisWorkbook.Worksheets("From Pact V1").Range("A2")
'with的作用就是简化代码，让代码简洁易懂
'让你不需要输入重复的内容也就是说with中以 . 开头的就相当这里的tarRange.
With tarRange

    Set myRange = myRange.Resize(RowSize:=.Rows.Count, ColumnSize:=.Columns.Count)
    '调整指定区域的大小。 返回一个 Range 对象，它表示已重设大小的区域。调整大小(RowSize, ColumnSize)

End With

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
'以上两句又是套路，代表要大量运算，怕机器受不了所以写这一对上去注意闭合

myRange.Value = tarRange.Value
'这句话就是最简单的把你框里的苹果放我框

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
'以上两句代表闭合，过河一定记得拆桥

Set tarRange = Nothing
Set myRange = Nothing
'就是要释放对象变量所占的内存空间需要set nothing最好加上这句，主要是怕机器太累，你俩换完苹果了，主动把筐子弄干净留给别人用


'------------------------------------------------------------------------------------

On Error Resume Next

Set tarRange = TarWb.Worksheets(TarTab).Range("E2:E" & xRow)
'就是选择E2到E结尾赋值给tarRange

If tarRange Is Nothing Then

   Revenue.Activate
   TarWb.Close SaveChanges:=False
   Exit Sub

End If


'---------------------------------------------------------------Copy DSO 4 to DSO Tool---------------------------------------------------------------

Set myRange = ThisWorkbook.Worksheets("From Pact V1").Range("D2")
'选择了From Pact V1这个sheet的D2列
With tarRange

    Set myRange = myRange.Resize(RowSize:=.Rows.Count, ColumnSize:=.Columns.Count)
    '把刚才那个DSO选中的tarRange的行和列的数值赋值给myRange

End With

'不说了，下面开始交换苹果了
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

myRange.Value = tarRange.Value

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

Set tarRange = Nothing
Set myRange = Nothing


'------------------------------------------------------------------------------------

On Error Resume Next

Set tarRange = TarWb.Worksheets(TarTab).Range("S2:S" & xRow)
'跟上面一样这次选择TarTab的S2到结尾

If tarRange Is Nothing Then

   Revenue.Activate
   TarWb.Close SaveChanges:=False
   '跟上面一样，就是用完了不保存直接退出
   '看到这里就看出来套路了吧这里的tarRange已经代表目标的S2列了下面还是如此炮制
   '猜的出来下面的步骤就要把这个选择好的目标列交给另外一个myRange，也就是交换苹果

   Exit Sub

End If


'---------------------------------------------------------------Copy DSO 5 to DSO Tool---------------------------------------------------------------

Set myRange = ThisWorkbook.Worksheets("From Pact V1").Range("E2")
'定义上面就是定义新的myRange，这个就相当于我手里的筐，我筐里装的E2这个列

With tarRange

    Set myRange = myRange.Resize(RowSize:=.Rows.Count, ColumnSize:=.Columns.Count)
    '这里就是测量一下你的筐里的苹果的长（行数）和宽（列数）然后我把我的筐子也改造这么大，就能装下你的苹果了

End With

'下面就是套路了，我们都准备好了，那么换苹果吧
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

myRange.Value = tarRange.Value

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

Set tarRange = Nothing
Set myRange = Nothing

'-------------------------------------换完苹果又该重新准备新的tarRange了-----------------------------------------------

On Error Resume Next

Set tarRange = TarWb.Worksheets(TarTab).Range("U2:U" & xRow)


If tarRange Is Nothing Then

   Revenue.Activate
   TarWb.Close SaveChanges:=False
   Exit Sub

End If


'---------------------------------------------------------------Copy DSO 6 to DSO Tool--定义我的筐然后实施交换-------------------------------------------------------------

Set myRange = ThisWorkbook.Worksheets("From Pact V1").Range("F2")

With tarRange

    Set myRange = myRange.Resize(RowSize:=.Rows.Count, ColumnSize:=.Columns.Count)

End With

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

myRange.Value = tarRange.Value

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

Set tarRange = Nothing
Set myRange = Nothing

'--------------------------------------做完交换后再定义下一个目标----------------------------------------------

On Error Resume Next

Set tarRange = TarWb.Worksheets(TarTab).Range("V2:V" & xRow)

If tarRange Is Nothing Then

   Revenue.Activate
   TarWb.Close SaveChanges:=False
   Exit Sub

End If


'--------------------------------------------------不想说了-------------Copy DSO 5 to DSO Tool---------------------------------------------------------------

Set myRange = ThisWorkbook.Worksheets("From Pact V1").Range("G2")

With tarRange

    Set myRange = myRange.Resize(RowSize:=.Rows.Count, ColumnSize:=.Columns.Count)

End With

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

myRange.Value = tarRange.Value

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

Set tarRange = Nothing
Set myRange = Nothing

TarWb.Close SaveChanges:=False
Revenue.Activate

MsgBox "Done ! SubData is loaded sucessfully." _
& vbNewLine & vbNewLine & "Next step, the program will map up supplymentary information for you."
'还的说两句，交换都成功了，然后打出上面这句英文，显得逼格高

'---------------------------------------------------------------Data Mapping-  映射，绘制地图的意思？？？？--------------------------------------------------------------

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

For i = 2 To xRow

DSO.Range("H" & i).Value = "=ROUND($F" & i & "-$G" & i & ",2)"
'对DSO的H列第i行单元格的值赋值，Round表示返回四舍五入到指定小数位数的数
'$J$5加了两个$符号可以确保公式复制到其他单元格时，还是$J$5（所谓[绝对引用]

DSO.Range("I" & i).Value = "=IF(ISERROR(VLOOKUP($C" & i & ",EATP!A:A,1,0)),""N"",""Y"")"

'=VLOOKUP(查找值,查找区域,返回查找区域第N列,查找模式)0精确，1模糊，iseror返回 TRUE 或 FALSE
‘这个公式的含义是：匹配C列的值再EATP 的A列存不存在，存在显示N，不存在显示Y
‘ excel中COUNTA(标签！A:A)（标签！A:A)   统计标签表中A列一共有多少个非空的单元格。



DSO.Range("J" & i).Value = "=IF(ISERROR(VLOOKUP($C" & i & ",'TAX FREE'!A:A,1,0)),""N"",""Y"")"
’如上一个公式

DSO.Range("L" & i).Value = "=IF($K" & i & "=0,0,IF($K" & i & "=1,MIN($F" & i & ",$H" & i & "),IF($K" & i & "=2,$F" & i & ",""输入金额"")))"
DSO.Range("M" & i).Value = "=ROUND($F" & i & "-$L" & i & ",2)"
DSO.Range("N" & i).Value = "=VLOOKUP($E" & i & ",'Exch Rate'!$A:$D,4,0)*'Unbilled AR Report'!F" & i & "/'Exch Rate'!$D$2"
DSO.Range("O" & i).Value = "=VLOOKUP($E" & i & ",'Exch Rate'!$A:$D,4,0)*'Unbilled AR Report'!H" & i & "/'Exch Rate'!$D$2"
DSO.Range("P" & i).Value = "=VLOOKUP($E" & i & ",'Exch Rate'!$A:$D,4,0)*'Unbilled AR Report'!L" & i & "/'Exch Rate'!$D$2"
DSO.Range("Q" & i).Value = "=VLOOKUP($E" & i & ",'Exch Rate'!$A:$D,4,0)*'Unbilled AR Report'!M" & i & "/'Exch Rate'!$D$2"
DSO.Range("S" & i).Value = "=$A" & i & ""
DSO.Range("T" & i).Value = "=VLOOKUP($S" & i & ",'LE List'!$B:$C,2,0)"
DSO.Range("U" & i).Value = "=VLOOKUP($B" & i & ",'LE List'!$A:$C,2,0)"
DSO.Range("R" & i).Value = "=$S" & i & "&$U" & i & ""
DSO.Range("V" & i).Value = "=VLOOKUP($B" & i & ",'LE List'!$A:$C,3,0)"
DSO.Range("W" & i).Value = "=VLOOKUP($T" & i & ",'LE List'!$C:$D,2,0)"
DSO.Range("X" & i).Value = "=VLOOKUP($U" & i & ",'LE List'!$B:$D,3,0)"
DSO.Range("Y" & i).Value = "=$C" & i & ""
DSO.Range("Z" & i).Value = "=$D" & i & ""
DSO.Range("AA" & i).Value = "=$L" & i & ""
DSO.Range("AB" & i).Value = "=IF($J" & i & "=""N"",IF(OR($A" & i & "=37,$A" & i & "=31,$A" & i & "=1002),IF(OR(LEFT($Y" & i & ",2)=""UW"",LEFT($Y" & i & ",2)=""VT""),""免税"",""非免税""),""非免税""),""免税"")"

Next i

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

DSO.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True _
        , AllowFormattingCells:=True, AllowFormattingColumns:=True, _
        AllowFormattingRows:=True, AllowInsertingRows:=True, AllowDeletingRows:= _
        True, AllowSorting:=True, AllowFiltering:=True, Password:="XXXXXX"

'上面是一些常规属性，具体我一个个给你翻译[详情]([https://docs.microsoft.com/zh-cn/office/vba/api/excel.protection.allowdeletingcolumns](https://docs.microsoft.com/zh-cn/office/vba/api/excel.protection.allowdeletingcolumns)
)
‘activesheet.protect -- 保护[工作表]
’drawingobjects=true，contents=true,scenarios=true -- 默认选项，保护表格对象、内容、和不定的内容（如公式）
‘AllowFormattingCells:=True如果允许对受保护的工作表上的单元格设置格式,则返回 True 
‘AllowFormattingColumns:=True如果在受保护的工作表上允许列的格式，则，返回True
‘AllowFormattingRows:=True允许用户对受保护的工作表上的行进行格式设置
‘AllowInsertingRows:=True允许用户在受保护的工作表上插入列
‘ AllowDeletingRows允许删除受保护的工作表上的行, 则返回True
’ AllowSorting允许在受保护的工作表上使用排序
‘AllowFiltering允许用户使用在工作表受保护之前创建的自动筛选器

MsgBox "Done ! data is mapping sucessfully."

End Sub
最后编辑于 ：
©著作权归作者所有,转载或内容合作请联系作者
平台声明：文章内容（如有图片或视频亦包括在内）由作者上传并发布，文章内容仅代表作者本人观点，简书系信息发布平台，仅提供信息存储服务。
  • 人面猴
    序言：七十年代末，一起剥皮案震惊了整个滨河市，随后出现的几起案子，更是在滨河造成了极大的恐慌，老刑警刘岩，带你破解...
    沈念sama阅读 227,748评论 6赞 531
  • 死咒
    序言：滨河连续发生了三起死亡事件，死亡现场离奇诡异，居然都是意外死亡，警方通过查阅死者的电脑和手机，发现死者居然都...
    沈念sama阅读 98,165评论 3赞 414
  • 救了他两次的神仙让他今天三更去死
    文/潘晓璐 我一进店门，熙熙楼的掌柜王于贵愁眉苦脸地迎上来，“玉大人，你说我怎么就摊上这事。” “怎么了？”我有些...
    开封第一讲书人阅读 175,595评论 0赞 373
  • 道士缉凶录：失踪的卖姜人
    文/不坏的土叔 我叫张陵，是天一观的道长。 经常有香客问我，道长，这世上最难降的妖魔是什么？ 我笑而不...
    开封第一讲书人阅读 62,633评论 1赞 309
  • 港岛之恋（遗憾婚礼）
    正文 为了忘掉前任，我火速办了婚礼，结果婚礼上，老公的妹妹穿的比我还像新娘。我一直安慰自己，他们只是感情好，可当我...
    茶点故事阅读 71,435评论 6赞 405
  • 恶毒庶女顶嫁案：这布局不是一般人想出来的
    文/花漫 我一把揭开白布。 她就那样静静地躺着，像睡着了一般。 火红的嫁衣衬着肌肤如雪。 梳的纹丝不乱的头发上，一...
    开封第一讲书人阅读 54,943评论 1赞 321
  • 城市分裂传说
    那天，我揣着相机与录音，去河边找鬼。 笑死，一个胖子当着我的面吹牛，可吹牛的内容都是我干的。 我是一名探鬼主播，决...
    沈念sama阅读 43,035评论 3赞 440
  • 双鸳鸯连环套：你想象不到人心有多黑
    文/苍兰香墨 我猛地睁开眼，长吁一口气：“原来是场噩梦啊……” “哼！你这毒妇竟也来了？” 一声冷哼从身侧响起，我...
    开封第一讲书人阅读 42,175评论 0赞 287
  • 万荣杀人案实录
    序言：老挝万荣一对情侣失踪，失踪者是张志新（化名）和其女友刘颖，没想到半个月后，有当地人在树林里发现了一具尸体，经...
    沈念sama阅读 48,713评论 1赞 333
  • 护林员之死
    正文 独居荒郊野岭守林人离奇死亡，尸身上长有42处带血的脓包…… 初始之章·张勋 以下内容为张勋视角 年9月15日...
    茶点故事阅读 40,599评论 3赞 354
  • 白月光启示录
    正文 我和宋清朗相恋三年，在试婚纱的时候发现自己被绿了。 大学时的朋友给我发了我未婚夫和他白月光在一起吃饭的照片。...
    茶点故事阅读 42,788评论 1赞 369
  • 活死人
    序言：一个原本活蹦乱跳的男人离奇死亡，死状恐怖，灵堂内的尸体忽然破棺而出，到底是诈尸还是另有隐情，我是刑警宁泽，带...
    沈念sama阅读 38,303评论 5赞 358
  • 日本核电站爆炸内幕
    正文 年R本政府宣布，位于F岛的核电站，受9级特大地震影响，放射性物质发生泄漏。R本人自食恶果不足惜，却给世界环境...
    茶点故事阅读 44,034评论 3赞 347
  • 男人毒药：我在死后第九天来索命
    文/蒙蒙 一、第九天 我趴在偏房一处隐蔽的房顶上张望。 院中可真热闹，春花似锦、人声如沸。这庄子的主人今日做“春日...
    开封第一讲书人阅读 34,412评论 0赞 25
  • 一桩弑父案，背后竟有这般阴谋
    文/苍兰香墨 我抬头看了看天上的太阳。三九已至，却和暖如春，着一层夹袄步出监牢的瞬间，已是汗流浃背。 一阵脚步声响...
    开封第一讲书人阅读 35,664评论 1赞 280
  • 情欲美人皮
    我被黑心中介骗来泰国打工， 没想到刚下飞机就差点儿被人妖公主榨干…… 1. 我叫王不留，地道东北人。 一个月前我还...
    沈念sama阅读 51,408评论 3赞 390
  • 代替公主和亲
    正文 我出身青楼，却偏偏与公主长得像，于是被迫代替她去往敌国和亲。 传闻我的和亲对象是个残疾皇子，可洞房花烛夜当晚...
    茶点故事阅读 47,747评论 2赞 370