excle 3招让你大把时间喝咖啡

最新推荐文章于 2021-07-29 14:40:00 发布

Captain_Data

最新推荐文章于 2021-07-29 14:40:00 发布

阅读量221

点赞数

分类专栏： vba

本文链接：https://blog.csdn.net/Captain_DUDU/article/details/103300070

版权

vba 专栏收录该内容

5 篇文章 0 订阅

订阅专栏

Sub a1()

'Application(CountA(Range("k:k")))
For i = 2 To Application.CountA(Range("k:k"))
    Sheets("房产数据").Select
    kv = Range("k" & i)
    
    ActiveSheet.PivotTables("数据透视表1").PivotFields("朝向").ClearAllFilters
    ActiveSheet.PivotTables("数据透视表1").PivotFields("朝向").CurrentPage = kv
    Range("M5:y121").Select
    Selection.Copy
    Sheets.Add After:=Sheets(Sheets.Count)
    Range("A1").Select
    ActiveSheet.Paste
    Sheets(i).Name = kv
    Sheets("房产数据").Select
    Next
End Sub

Sub a2()
Windows("房产数据.xlsm").Activate
    Sheets("房产数据").Select
'Application(CountA(Range("k:k")))
For i = 2 To Application.CountA(Range("k:k"))
    Sheets("房产数据").Select
    kv = Range("k" & i)
    
    ActiveSheet.PivotTables("数据透视表1").PivotFields("朝向").ClearAllFilters
    ActiveSheet.PivotTables("数据透视表1").PivotFields("朝向").CurrentPage = kv
    Range("M5:y121").Select
    Selection.Copy
    
    Workbooks.Add
    ActiveWorkbook.Sheets("sheet1").Select
    Range("A1").Select
    ActiveWorkbook.ActiveSheet.Paste
    
    
    ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path + "\方位文件\" + kv + ".xlsx"
    ActiveWindow.Close
    
    Windows("房产数据.xlsm").Activate
    Sheets("房产数据").Select
    Next
End Sub

Sub a3()

Windows("房产数据.xlsm").Activate
    Sheets("房产数据").Select
'Application(CountA(Range("k:k")))
For i = 2 To Application.CountA(Range("k:k"))
    Sheets("房产数据").Select
    kv = Range("k" & i)
    ActiveSheet.PivotTables("数据透视表1").PivotFields("朝向").ClearAllFilters
    ActiveSheet.PivotTables("数据透视表1").PivotFields("朝向").CurrentPage = kv
    
    Set wdapp = CreateObject("word.application")
    wdapp.documents.Add
    num = Application.CountA(Range("m:m")) - 4
    
    wdapp.Visible = True
    
    wdapp.documents(1).Tables.Add Range:=wdapp.Selection.Range, NumRows:=num, NumColumns:=13
    'wdapp.documents (1).
    wdapp.documents(1).Tables(1).Style = "浅色底纹 - 强调文字颜色 3"
    n = 1
    For J = 13 To 25 '遍历行头
        wdapp.documents(1).Tables(1).Range.Cells(n) = Cells(5, J)
        n = n + 1
    Next
    
    
    '搬运
    For k = 6 To num
        For L = 13 To 25
        wdapp.documents(1).Tables(1).Range.Cells(n) = Cells(k, L)
        n = n + 1
        Next
    Next
    wdapp.documents(1).SaveAs ThisWorkbook.Path + "\房产数据word\" + kv + ".docx"
    wdapp.Quit
Next
End Sub

练习资源：https://pan.baidu.com/s/1V5sK1BfoKuD1vlJ9eXipZg

Sub a1()

    '路径
    expath = ThisDocument.Path + "\"
    '关联excle
    Set exapp = CreateObject("excel.application")
    '显示
    exapp.Visible = True
    '打开工作簿
    exapp.workbooks.Open (expath + "成绩单 - 副本")
    
    '选中表格
    exapp.sheets("sheet1").Select
    
    '生成 几个文档
    
    Num = exapp.Application.counta(exapp.Range("a:a")) - 1
    
    Debug.Print Str1
    For i = 2 To Num
    FName = exapp.Range("a" & i)
        'Debug.Print Num
         FileCopy expath + "成绩通知单.docx", "成绩单/" + FName + ".docx"
         '打开文档
        Set doc = Documents.Open(expath + "成绩单/" + FName + ".docx")
         '定位修改位置
            With Selection.Find
                .Text = "某某"
                .Forward = True
                .Replacement.Text = FName
                .Execute Replace:=wdReplaceAll
            End With
            
            '定位到综合评价后
            With Selection.Find
                .Text = "成绩如下："
                .Forward = True
                .Execute
            End With
            
            Selection.MoveDown unit:=wdLine, Count:=1
            
            '插入表格
            Selection.Tables.Add Selection.Range, 2, 5
            
            Selection.Tables(1).Style = "网格型"
            
            '搬运标头
            For j = 1 To 5
                doc.Tables(1).Range.Cells(j) = exapp.Cells(1, j) '搬运标头
                doc.Tables(1).Range.Cells(j + 5) = exapp.Cells(i, j) '搬运成绩
            Next
            
            '成绩判断模块
            If exapp.Range("f" & i) > 2 And exapp.Range("g" & i) = 0 Then
            strPJ = "你的孩子很优秀，继续保持"
            ElseIf exapp.Range("f" & i) > 0 And exapp.Range("g" & i) > 0 Then
            strPJ = "你的孩子有偏科情况"
            ElseIf exapp.Range("f" & i) = 0 And exapp.Range("g" & i) >= 0 Then
            strPJ = "你的孩子成绩不理想，希望家长多关注"
            Else
            strPJ = "你的孩子成绩中等水平，请继续努力"
            End If
            
            '评价模块
            
            With Selection.Find
               .Text = "综合评价："
               .Forward = True
               .Execute
            End With
            Selection.InsertAfter Text:=strPJ
                  
            doc.Save
            doc.Close
    Next
    exapp.Quit
End Sub

Sub a1()

expath = ThisDocument.Path + "\"

Set exapp = CreateObject("excel.application")

'显示
exapp.Visible = True

exapp.workbooks.Open (expath + "洗衣机品牌.xlsx")
 
exapp.sheets("sheet1").Select

'生成文档数
Num = exapp.Application.counta(exapp.Range("a:a")) - 1

For i = 2 To Num

FName = exapp.Range("a" & i)
        'Debug.Print expath + "模板.docx"
         FileCopy expath + "模板.docx", expath + "洗衣机文件\" + FName + ".docx"
         '打开文档
        Set doc = Documents.Open(expath + "洗衣机文件\" + FName + ".docx")
         '定位修改位置
            With Selection.Find
                .Text = "某品牌"
                .Forward = True
                .Replacement.Text = FName
                .Execute Replace:=wdReplaceAll
            End With
            
            '定位到综合评价后
            With Selection.Find
                .Text = "情况如下："
                .Forward = True
                .Execute
            End With
            
            Selection.MoveDown unit:=wdLine, Count:=1
            
            '插入表格
            Selection.Tables.Add Selection.Range, 2, 5
            
            Selection.Tables(1).Style = "彩色列表 - 强调文字颜色 3"
            
            '搬运标头
            For j = 1 To 5
                doc.Tables(1).Range.Cells(j) = exapp.Cells(1, j) '搬运标头
                doc.Tables(1).Range.Cells(j + 5) = exapp.Cells(i, j) '搬运内容
            Next
            
'            '成绩判断模块
'            If exapp.Range("f" & i) > 2 And exapp.Range("g" & i) = 0 Then
'            strPJ = "你的孩子很优秀，继续保持"
'            ElseIf exapp.Range("f" & i) > 0 And exapp.Range("g" & i) > 0 Then
'            strPJ = "你的孩子有偏科情况"
'            ElseIf exapp.Range("f" & i) = 0 And exapp.Range("g" & i) >= 0 Then
'            strPJ = "你的孩子成绩不理想，希望家长多关注"
'            Else
'            strPJ = "你的孩子成绩中等水平，请继续努力"
'            End If
'
'            '评价模块

            strPJ = "描述:" & FName & "品牌月销量是" & exapp.Range("c" & i) & "，排名第" & exapp.Range("f" & i) & "名，好评率达到了" & Format(exapp.Range("d" & i) / exapp.Range("e" & i), "Percent") & "，与最高品牌差距为" & exapp.Range("g" & i) & "件"
            
            With Selection.Find
               .Text = "描述:"
               .Forward = True
               .Replacement.Text = strPJ
               .Execute Replace:=wdReplaceAll
            End With
            
            
            
            With Selection.Find
               .Text = "各品牌月销量对比图"
               .Forward = True
               .Execute
            End With
            Selection.MoveDown unit:=wdLine, Count:=1
            
            exapp.Activesheet.ChartObjects("图表 1").Activate
            exapp.Activechart.ChartArea.Copy
            Selection.Paste
            doc.Save
            doc.Close
    Next
    exapp.Quit


   
End Sub

Sub 导表()

    expath = ThisDocument.Path & "\"
    Set exapp = CreateObject("excel.application")
    exapp.Visible = True
    exapp.workbooks.Open (expath + "销量情况.xlsx")
    exapp.sheets("Sheet2").Select
    '城市数量
    citys_Num = exapp.Application.counta(exapp.Range("j:j")) - 1
    For i = 2 To 2
        CityName = exapp.Range("j" & 2)
        miaoshu = exapp.Range("e21")
        
       '数据透视表索引
        exapp.ActiveSheet.PivotTables("数据透视表1").PivotFields("客户省份").ClearAllFilters
        exapp.ActiveSheet.PivotTables("数据透视表1").PivotFields("客户省份").CurrentPage = CityName
       
       FileCopy expath + "模板.docx", expath + "地区文件\" + CityName + ".docx"
         '打开文档
        
        Set doc = Documents.Open(expath + "地区文件\" + CityName + ".docx")
        '替换某某
        With Selection.Find
                .Text = "某某"
                .Forward = True
                .Replacement.Text = CityName
                .Execute Replace:=wdReplaceAll
        End With
        
        
         With Selection.Find
                .Text = "某"
                .Forward = True
                .Replacement.Text = CityName
                .Execute Replace:=wdReplaceAll
        End With
                
         With Selection.Find
                .Text = "各地区销量排行前10名"
                .Forward = True
                .Execute
        End With
        
        Selection.MoveDown unit:=wdLine, Count:=1
        '插入表格
            Selection.Tables.Add Selection.Range, 11, 2
            Selection.Tables(1).Style = "网格型"
            '搬运
            
            n = 1
            For j = 1 To 11
                For k = 1 To 2
                doc.Tables(1).Range.Cells(n) = exapp.Cells(j + 1, k + 4)
                n = n + 1
                Next
            Next
                
                
      
       
        
         '图1
         
         With Selection.Find
                .Text = "广西"
                .Forward = True
                .Execute
        End With
       
        Selection.MoveDown unit:=wdLine, Count:=2
         
       exapp.ActiveSheet.ChartObjects("图表 1").Activate
       exapp.Activechart.ChartArea.Copy
       Selection.Paste
        
        
        '图2
        With Selection.Find
                .Text = "地区产品销量排行前10名"
                .Forward = True
                .Execute
        End With
        
        Selection.MoveDown unit:=wdLine, Count:=1
        exapp.ActiveSheet.ChartObjects("图表 4").Activate
        exapp.Activechart.ChartArea.Copy
        Selection.Paste
       
       
        With Selection.Find
                .Text = "综合描述："
                .Forward = True
                .Replacement.Text = miaoshu
                .Execute Replace:=wdReplaceAll
        End With
        
         
         '图3
         
         With Selection.Find
                .Text = "地区各产品销售量情况对比图"
                .Forward = True
                .Execute
        End With
       
        Selection.MoveDown unit:=wdLine, Count:=2
         
       exapp.ActiveSheet.ChartObjects("图表 3").Activate
       exapp.Activechart.ChartArea.Copy
       Selection.Paste
        
       
        '词云
       ' Debug.Print exapp.Application.counta(exapp.Range("j:j"))
       
       Str
        For u = 4 To exapp.Application.counta(Range("j:j")) - 2
            str1 = str1 + exapp.Range("a" & u) + "  "
            
        Next
        exapp.ActiveSheet.Shapes.Range(Array("TextBox 2")).Select
        exapp.Selection.ShapeRange(1).TextFrame2.TextRange.Characters.Text = str1
        
        

   Next

    
End Sub

Captain_Data

关注

0
点赞
踩
0

收藏

觉得还不错? 一键收藏
打赏
0
评论
excle 3招让你大把时间喝咖啡

1Sub a1()'Application(CountA(Range("k:k")))For i = 2 To Application.CountA(Range("k:k")) Sheets("房产数据").Select kv = Range("k" & i) ActiveSheet.PivotTables("数据透视表1").PivotField...
复制链接

扫一扫