1
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
3
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