Sub 复制费用()
'
' 复制费用 宏
'

'
'寻找广告费
adverst = Dir("D:\众结资料\1日常工作内容\每日销售开发业绩(Python)\" & Application.WorksheetFunction.Text(Date, "yyyymmdd") & "\每日广告费.csv")
If adverst = "" Then
    MsgBox "未找到广告费"
    Exit Sub
    Else
End If

'寻找推广费
promo = Dir("D:\众结资料\1日常工作内容\每日销售开发业绩(Python)\" & Application.WorksheetFunction.Text(Date, "yyyymmdd") & "\每日推广费.csv")
If promo = "" Then
    MsgBox "未找到推广费"
    Exit Sub
    Else
End If

HROW9 = Sheets("费用").[H2].CurrentRegion.Rows.Count
HROW10 = Sheets("费用").[W2].CurrentRegion.Rows.Count


'删除原有数据

Sheets("费用").Range("H2:K" & HROW9).Clear
Sheets("费用").Range("W2:Z" & HROW10).Clear


'复制广告数据
Set advercopy = Workbooks.Open("D:\众结资料\1日常工作内容\每日销售开发业绩(Python)\" & Application.WorksheetFunction.Text(Date, "yyyymmdd") & "\" & adverst)
HROWadvercopy = advercopy.Sheets("每日广告费").[A2].CurrentRegion.Rows.Count
advercopy.Sheets("每日广告费").Range("A2:D" & HROWadvercopy).Copy ThisWorkbook.Worksheets("费用").Range("H2")
advercopy.Close SaveChanges:=False

'复制推广数据
Set promocopy = Workbooks.Open("D:\众结资料\1日常工作内容\每日销售开发业绩(Python)\" & Application.WorksheetFunction.Text(Date, "yyyymmdd") & "\" & promo)
HROWpromocopy = promocopy.Sheets("每日推广费").[A2].CurrentRegion.Rows.Count
promocopy.Sheets("每日推广费").Range("A2:F" & HROWpromocopy).Copy ThisWorkbook.Worksheets("费用").Range("W2")
promocopy.Close SaveChanges:=False




End Sub

前言：因为考虑数据量的问题，所以在计算季度数据的时候，做了一个辅助列“季度累计数（至上月）”，季度累计数=本月发展数+季度累计数（至上月），这样就碰到一个问题：需要每个月都把季度累计数复制到季度累计数（至上月）
 如果列数少的话还好，列数一多真的要奔溃；如果每个月还有要改模板的话，就更讨厌了
 所以用vba写了一段脚本，自动做上述工作，只需要确定好从什么名字的列复制到什么名字的列即可
 
Sub 季度数据复制()

'获得最大行数
Sheets("门店维度").Select
maxrow = Sheets("门店维度").UsedRange.Rows.Count - 1 '因为我最后一行是合计的公式，所以不复制

'构建字典，key是原始列（需要复制的），value是目标列（需要黏贴的）
Dim dict As Object
Set dict = CreateObject("scripting.dictionary")
dict.Add "宽带季度完成数", "宽带季度完成数（至上月）"
dict.Add "季度累计融合发展量", "季度累计融合发展量（至上月）"
dict.Add "季度累计非主流融合发展量", "季度累计非主流融合发展量（至上月）"
dict.Add "季度累计129及以上发展量", "季度累计129及以上发展量（至上月）"
dict.Add "价值宽带季度完成数", "价值宽带季度完成数（至上月）"
dict.Add "移动季度完成数", "移动季度完成数（至上月）"
dict.Add "新战狼季度完成数", "新战狼季度完成数（至上月）"
dict.Add "199+30季度累计", "199+30季度累计（至上月）"
dict.Add "精品智能组网季度累计", "精品智能组网季度累计（至上月）"
dict.Add "50G包季度累计", "50G包季度累计（至上月）"
dict.Add "宽带提速包季度累计", "宽带提速包季度累计（至上月）"
dict.Add "橙分期季度累计", "橙分期季度累计（至上月）"

For Each k In dict
    k_column = Rows(3).Find(k, LookAt:=xlWhole).Column '在第三行里找到和k一模一样的值的列号，如5
    v = dict.Item(k)
    v_column = Rows(3).Find(v, LookAt:=xlWhole).Column '获得value的列号，如6
    Range(Cells(4, k_column), Cells(maxrow, k_column)).Select
    Range(Cells(4, k_column), Cells(maxrow, k_column)).Copy
    Cells(4, v_column).Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
Next
 
End Sub

我们项目管理有两个工作薄，一个里面有多个表，每天建一个，记录当天项目，另一个工作薄，有多个表，其中一个是所有项目汇总。
 
以前都是第一个工作薄一个表做完，再复制粘贴到第二个工作薄的汇总表中。
 
写了个VBA宏完成这个工作。
 
 
Sub CopyToOtherBook()
'
' copyToOtheBook Macro
' 宏由 cuianzhu 录制，时间: 2013-6-18
'

'
    Dim fname As String
    Dim maxLine As Integer
    Dim maxLineS As String
    Dim wb As Workbook
    Dim curSheet As String
    
    '除去表头，所有行选中
    maxLine = ActiveSheet.UsedRange.Rows.Count
    maxLineS = "2:" + CStr(maxLine)
    Rows(maxLineS).Select
    '复制
    Selection.Copy
    
    
    fpath = "D:\\XXX\\"
    fname = "第二个工作薄.xls"
    curSheet = "汇总表"
    
    '打开第二个工作薄，激活汇总表
    Set wb = Workbooks.Open(fpath + fname)
    wb.Worksheets(curSheet).Activate
    
    '找到最后一行
    maxLine = ActiveSheet.UsedRange.Rows.Count
    '选中最后一行下一行第一个表格
    Cells(maxLine + 1, 1).Select
    '粘贴
    ActiveSheet.Paste
    ActiveWorkbook.Save
    ActiveWorkbook.Close
    
End Sub

 
然后在对应的表里执行该宏，就可以把所有该表的数据复制到另一个工作薄的汇总表里了。 
 

 

前言：之前在使用工作簿与工作簿之间的数据连接时，使用的是vlookup手动做链接，然后断开连接并另存为的方式，虽然做好一次后很方便，但是每次变动需求要修改的话都好累。比如我这里有36个，也就是相当于要做36次vlookup！
 所以干脆写了一段代码，把一个工作簿里的数据直接黏贴到另一个工作簿里，根据列名自动查找匹配
 注：这里用的是字典，如果两个工作簿的列名一致的话，可以用数组来代替，更方便。
 
Sub 日报数据复制(blank As String)

'获得最大行数
maxrow = Workbooks("！源数据（每日刷新）.xlsm").Sheets("日报数据").UsedRange.Rows.Count

'构建字典，key是原始列（需要复制的），value是目标列（需要黏贴的）
Dim dict As Object
Set dict = CreateObject("scripting.dictionary")
dict.Add "日宽带发展量", "日宽带"
dict.Add "月宽带发展量", "月宽带"
dict.Add "日移动发展", "日移动"
dict.Add "月移动发展", "月移动"
dict.Add "日5G新增套餐", "日5G新增套餐"
dict.Add "日5G存量套餐", "日5G存量套餐"
dict.Add "日5G包", "日5G包"
dict.Add "月5G新增套餐", "月5G新增套餐"
dict.Add "月5G存量套餐", "月5G存量套餐"
dict.Add "月5G包", "月5G包"
dict.Add "日销售额", "日销售额"
dict.Add "月销售额", "月销售额"
dict.Add "日129及以上", "日129及以上套餐"
dict.Add "月129及以上", "月129及以上套餐"
dict.Add "月新增公客", "月公客宽带发展数"
dict.Add "日主动拆机", "日宽带主动拆机"
dict.Add "日宽带在线", "日宽带在线"
dict.Add "月主动拆机", "月宽带主动拆机"
dict.Add "月宽带在线", "月宽带在线"
dict.Add "日橙分期", "日橙分期"
dict.Add "月橙分期", "月橙分期"
dict.Add "日叠叠乐", "日叠叠乐"
dict.Add "月叠叠乐", "月叠叠乐"
dict.Add "月叠叠乐副卡", "月新增副卡"
dict.Add "日全屋wifi", "日全屋WIFI"
dict.Add "月全屋wifi", "月全屋WIFI"
dict.Add "日收费家庭云", "日家庭云"
dict.Add "月收费家庭云", "月家庭云"
dict.Add "新增宽带家庭云分母", "新增宽带叠加率分母"
dict.Add "新增宽带家庭云分子", "新增宽带叠加率分子"
dict.Add "日天翼看家", "日天翼看家"
dict.Add "月天翼看家", "月天翼看家"
dict.Add "日小翼管家", "日小翼管家"
dict.Add "月小翼管家", "月小翼管家"
dict.Add "日播播TV", "日播播TV"
dict.Add "月播播TV", "月播播TV"

For Each k In dict
    k_column = Workbooks("！源数据（每日刷新）.xlsm").Sheets("日报数据").Rows(1).Find(k, LookAt:=xlWhole).Column '在第三行里找到和k一模一样的值的列号，如5
    k_col = CNtoW(k_column)
    v = dict.Item(k)
    v_column = Workbooks("日报模板（会用宏的可以用用）.xlsm").Sheets("门店维度").Rows(3).Find(v, LookAt:=xlWhole).Column '获得value的列号，如6
    v_col = CNtoW(v_column)
    Workbooks("！源数据（每日刷新）.xlsm").Sheets("日报数据").Range(k_col & "2:" & k_col & maxrow).Copy
    Workbooks("日报模板（会用宏的可以用用）.xlsm").Sheets("门店维度").Range(v_col & "4:" & v_col & (maxrow + 3)).PasteSpecial Paste:=xlPasteFormulas
Next
 
End Sub

'列数转字母
Function CNtoW(ByVal num As Long) As String
    CNtoW = Replace(Cells(1, num).Address(False, False), "1", "")
End Function

'字母转列数
Function CWtoN(ByVal AB As String) As Long
    CWtoN = Range("a1:" & AB & "1").Cells.Count
End Function