Sub 刷新所有数据()
' 刷新当前工作簿中的所有外部数据连接和数据透视表
ThisWorkbook.RefreshAll
' 等待刷新操作完成
Application.CalculateUntilAsyncQueriesDone
End Sub
' 参数：源文件路径, 目标sheet名, 粘贴到目标sheet的起始单元格例如A1
Sub 导入数据_保留源文件格式(sourcePath As String, sheetName As String, cellLocation As String)
Dim sourceBook As Workbook
Set sourceBook = Workbooks.Open(sourcePath)
sourceBook.Sheets(1).UsedRange.Copy
ThisWorkbook.Sheets(sheetName).Range(cellLocation).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
Application.CutCopyMode = False
sourceBook.Close False
End Sub
' 参数：源文件路径, 目标sheet名, 粘贴到目标sheet的起始单元格例如A1
Sub 导入数据_数值(sourcePath As String, sheetName As String, cellLocation As String)
Dim sourceBook As Workbook
Set sourceBook = Workbooks.Open(sourcePath)
sourceBook.Sheets(1).UsedRange.Copy
ThisWorkbook.Sheets(sheetName).Range(cellLocation).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
sourceBook.Close False
End Sub
' 参数：sheet名, 起始行号，终止行号， 起始列号， 终止列号
Sub 拉公式(sheetName As String, startRow As Long, endRow As Long, startCol As Integer, endCol As Integer)
Dim formulaRange As Range
Dim startCell As Range
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets(sheetName)
ws.Activate
' 定义起始单元格区域
Set startCell = ws.Cells(startRow, startCol).Resize(1, endCol - startCol + 1)
' 定义要填充公式的范围
Set formulaRange = ws.Range(startCell, Cells(endRow, endCol))
' 将起始单元格区域的公式向下填充到指定范围
startCell.AutoFill Destination:=formulaRange, Type:=xlFillDefault
End Sub
' 参数：目标sheet名, 起始列标， 终止列标
Sub 文本转数值(sheetName As String, startCol As String, endCol As String)
Dim ws As Worksheet
Dim lastRow As Long, col As Range
Dim rngToConvert As Range
' 设置参数
Set ws = ThisWorkbook.Sheets(sheetName) ' 修改为你的工作表名
Application.ScreenUpdating = False
On Error Resume Next
' 查找有数据的最后一行
lastRow = ws.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
' 设置要转换的范围
Set rngToConvert = ws.Range(ws.Cells(1, startCol), ws.Cells(lastRow, endCol))
' 仅转换有数据的单元格
With rngToConvert
.NumberFormat = "General"
' 方法2：更安全的转换（处理各种数字格式）
.TextToColumns Destination:=.Cells(1), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, _
Tab:=False, Semicolon:=False, Comma:=False, Space:=False, _
Other:=False, FieldInfo:=Array(1, 1)
' 设置数字格式（可选）
' .NumberFormat = "0.00"
End With
Application.ScreenUpdating = True
On Error GoTo 0
End Sub
' 参数：sheet名, 起始行号，列号
Sub 去重(sheetName As String, startRow As Long, colToCheck As Integer)
Dim ws As Worksheet
Dim lastRow As Long
' 设置要操作的工作表
Set ws = ThisWorkbook.Sheets(sheetName) ' 修改为你的表名
' 设置要检查重复项的列 (例如：1 = A列, 2 = B列, 3 = C列, 依此类推)
colToCheck = 1 ' 修改为你要检查的列号
' 找出该列的最后一行
lastRow = ws.Cells(ws.Rows.Count, colToCheck).End(xlUp).Row
' 确保起始行不超过最后一行
If startRow > lastRow Then
MsgBox "起始行大于数据的最后一行！", vbExclamation
Exit Sub
End If
' 删除重复项
ws.Range(ws.Cells(startRow, colToCheck), ws.Cells(lastRow, colToCheck)).RemoveDuplicates Columns:=1, Header:=xlNo
End Sub
Sub 批量执行()
Call 导入指定区域数据_保留源文件格式("E:\吕新增报表\数据\当月原套餐18+降档客户清单.xlsx", "Sheet1", "A3:", "C1")
Call 导入数据_数值("E:\吕新增报表\数据\当月原套餐18+降档客户清单.xlsx", "Sheet1", "A3:", "C1")
Call 拉公式("Sheet1", 2, 10000, 1, 3)
Call 文本转数值("Sheet1", "N", "R")
Call 去重("Sheet1", 2, 3)
End Sub
=====================================================
' 参数：源文件路径, 目标sheet名, 粘贴到目标sheet的起始单元格例如A1
Sub 导入数据_保留源文件格式(sourcePath As String, sheetName As String, cellLocation As String)
Call 删除数据(sheetName, cellLocation)
' 创建FileSystemObject
Set fso = CreateObject("Scripting.FileSystemObject")
' 检查文件是否存在
If Not fso.FileExists(sourcePath) Then
MsgBox "文件不存在: " & sourcePath, vbExclamation
Exit Sub
End If
Dim sourceBook As Workbook
Set sourceBook = Workbooks.Open(sourcePath)
sourceBook.Sheets(1).UsedRange.Copy
ThisWorkbook.Sheets(sheetName).Range(cellLocation).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
Application.CutCopyMode = False
sourceBook.Close False
End Sub
' 参数：源文件路径, 目标sheet名, 粘贴到目标sheet的起始单元格例如A1
Sub 导入数据_数值(sourcePath As String, sheetName As String, cellLocation As String)
Call 删除数据(sheetName, cellLocation)
' 创建FileSystemObject
Set fso = CreateObject("Scripting.FileSystemObject")
' 检查文件是否存在
If Not fso.FileExists(sourcePath) Then
MsgBox "文件不存在: " & sourcePath, vbExclamation
Exit Sub
End If
Dim sourceBook As Workbook
Set sourceBook = Workbooks.Open(sourcePath)
sourceBook.Sheets(1).UsedRange.Copy
ThisWorkbook.Sheets(sheetName).Range(cellLocation).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
sourceBook.Close False
End Sub
' 参数：源文件路径, 目标sheet名, 粘贴到目标sheet的起始单元格例如A1
Sub 导入指定区域数据_数值(sourcePath As String, startRow As Long, startColLetter As String, endColLetter As String, sheetName As String, cellLocation As String)
Call 删除数据(sheetName, cellLocation)
' 创建FileSystemObject
Set fso = CreateObject("Scripting.FileSystemObject")
' 检查文件是否存在
If Not fso.FileExists(sourcePath) Then
MsgBox "文件不存在: " & sourcePath, vbExclamation
Exit Sub
End If
Dim sourceBook As Workbook
Set sourceBook = Workbooks.Open(sourcePath)
' 复制指定范围的数据
sourceBook.Sheets(1).Range(startColLetter & startRow & ":" & endColLetter & sourceBook.Sheets(1).UsedRange.Rows.Count).Copy
ThisWorkbook.Sheets(sheetName).Range(cellLocation).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
sourceBook.Close False
End Sub
' 参数：源文件路径, 目标sheet名, 粘贴到目标sheet的起始单元格例如A1
Sub 导入指定区域数据_保留源文件格式(sourcePath As String, startRow As Long, startColLetter As String, endColLetter As String, sheetName As String, cellLocation As String)
Call 删除数据(sheetName, cellLocation)
' 创建FileSystemObject
Set fso = CreateObject("Scripting.FileSystemObject")
' 检查文件是否存在
If Not fso.FileExists(sourcePath) Then
MsgBox "文件不存在: " & sourcePath, vbExclamation
Exit Sub
End If
Dim sourceBook As Workbook
Set sourceBook = Workbooks.Open(sourcePath)
' 复制指定范围的数据
sourceBook.Sheets(1).Range(startColLetter & startRow & ":" & endColLetter & sourceBook.Sheets(1).UsedRange.Rows.Count).Copy
ThisWorkbook.Sheets(sheetName).Range(cellLocation).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
Application.CutCopyMode = False
sourceBook.Close False
End Sub
Sub 导入文本文档(sourcePath As String, sheetName As String, cellLocation As String)
Dim fso As Object
Dim targetSheet As Worksheet
Dim targetCell As Range
Dim fileContent As String
Call 删除数据(sheetName, cellLocation)
' 创建FileSystemObject
Set fso = CreateObject("Scripting.FileSystemObject")
' 检查文件是否存在
If Not fso.FileExists(sourcePath) Then
MsgBox "文件不存在: " & sourcePath, vbExclamation
Exit Sub
End If
' 读取文件内容
fileContent = fso.OpenTextFile(sourcePath).ReadAll
' 复制到剪贴板
With CreateObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
.SetText fileContent
.PutInClipboard
End With
' 设置目标工作表和单元格
Set targetSheet = ThisWorkbook.Worksheets(sheetName) ' 修改为你的工作表名
Set targetCell = targetSheet.Range(cellLocation) ' 修改为你想要粘贴的单元格
' 激活目标工作表（可选）
targetSheet.Activate
' 选中目标单元格并粘贴
targetCell.Select
targetSheet.Paste
End Sub
' 删除指定单元格及其右下方所有数据
Sub 删除数据备份(sheetName As String, cellLocation As String)
Dim ws As Worksheet
Dim startCell As Range
Dim lastRow As Long
Dim lastCol As Long
Dim clearRange As Range
' 设置要处理的工作表名称
Set ws = ThisWorkbook.Sheets(sheetName)
' 设置起始单元格（例如: "C5"）
Set startCell = ws.Range(cellLocation).Offset(10, 0)
Application.ScreenUpdating = False
' 确定数据区域的最后一行和最后一列
lastRow = ws.Cells(ws.Rows.Count, startCell.Column).End(xlUp).Row
lastCol = ws.Cells(startCell.Row, ws.Columns.Count).End(xlToLeft).Column
' 如果最后一行或最后一列小于起始单元格的位置，则使用起始单元格的值
If lastRow < startCell.Row Then lastRow = startCell.Row
If lastCol < startCell.Column Then lastCol = startCell.Column
' 设置要清空的范围
Set clearRange = ws.Range(startCell, ws.Cells(lastRow, lastCol))
' 清空范围内容
clearRange.ClearContents
Application.ScreenUpdating = True
End Sub
' 删除指定单元格及其右下方所有行
Sub 删除数据(sheetName As String, cellLocation As String)
Dim ws As Worksheet
Dim startCell As Range
Dim cellAddress As String
Dim lastRow As Long
' 设置要处理的工作表名称
Set ws = ThisWorkbook.Sheets(sheetName)
' 设置起始单元格地址（例如: "A5"）
cellAddress = "A5"
' 找到起始单元格
Set startCell = ws.Range(cellLocation).Offset(10, 0)
' 计算要删除的行数
lastRow = ws.Cells(ws.Rows.Count, startCell.Column).End(xlUp).Row
Dim rowsToDelete As Long
rowsToDelete = lastRow - startCell.Row + 1
' 确保有行可删除
If rowsToDelete > 0 Then
' 关闭屏幕更新以提高性能
Application.ScreenUpdating = False
' 删除从起始单元格开始的所有行
ws.Range(startCell, ws.Cells(lastRow, ws.Columns.Count)).EntireRow.Delete
' 恢复屏幕更新
Application.ScreenUpdating = True
End If
End Sub
' 参数：sheet名, 起始行号，终止行号， 起始列号， 终止列号
Sub 拉公式(sheetName As String, startRow As Long, endRow As Long, startCol As Integer, endCol As Integer)
Dim formulaRange As Range
Dim startCell As Range
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets(sheetName)
ws.Activate
' 定义起始单元格区域
Set startCell = ws.Cells(startRow, startCol).Resize(1, endCol - startCol + 1)
' 定义要填充公式的范围
Set formulaRange = ws.Range(startCell, Cells(endRow, endCol))
' 将起始单元格区域的公式向下填充到指定范围
startCell.AutoFill Destination:=formulaRange, Type:=xlFillDefault
End Sub
' 参数：sheet名, 起始行号，终止行号， 起始列号， 终止列号
Sub 拉公式(sheetName As String, startRow As Long, endRow As Long, startCol As Integer, endCol As Integer)
Dim formulaRange As Range
Dim startCell As Range
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets(sheetName)
ws.Activate
' 定义起始单元格区域
Set startCell = ws.Cells(startRow, startCol).Resize(1, endCol - startCol + 1)
' 定义要填充公式的范围
Set formulaRange = ws.Range(startCell, Cells(endRow, endCol))
' 将起始单元格区域的公式向下填充到指定范围
startCell.AutoFill Destination:=formulaRange, Type:=xlFillDefault
End Sub
' 以指定列为准，公式拉到指定列的最后一行，防止超出范围
Sub 拉公式_指定列(sheetName As String, startRow As Long, rowsOfCol As String, startCol As Integer, endCol As Integer)
Dim formulaRange As Range
Dim startCell As Range
Dim endRow As Long
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets(sheetName)
ws.Activate
endRow = Cells(Rows.Count, rowsOfCol).End(xlUp).Row
' 定义起始单元格区域
Set startCell = ws.Cells(startRow, startCol).Resize(1, endCol - startCol + 1)
' 定义要填充公式的范围
Set formulaRange = ws.Range(startCell, Cells(endRow, endCol))
' 将起始单元格区域的公式向下填充到指定范围
startCell.AutoFill Destination:=formulaRange, Type:=xlFillDefault
End Sub
' 参数：目标sheet名, 起始列标， 终止列标
Sub 文本转数值(sheetName As String, startCol As String, endCol As String)
Dim ws As Worksheet
Dim lastRow As Long, col As Range
Dim rngToConvert As Range
' 设置参数
Set ws = ThisWorkbook.Sheets(sheetName) ' 修改为你的工作表名
Application.ScreenUpdating = False
On Error Resume Next
' 查找有数据的最后一行
lastRow = ws.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
' 设置要转换的范围
Set rngToConvert = ws.Range(ws.Cells(1, startCol), ws.Cells(lastRow, endCol))
' 仅转换有数据的单元格
With rngToConvert
' .NumberFormat = "General"
' 方法2：更安全的转换（处理各种数字格式）
.TextToColumns Destination:=.Cells(1), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, _
Tab:=False, Semicolon:=False, Comma:=False, Space:=False, _
Other:=False, FieldInfo:=Array(1, 1)
' 设置数字格式（可选）
' .NumberFormat = "0.00"
End With
Application.ScreenUpdating = True
On Error GoTo 0
End Sub
' 参数：sheet名, 起始行号，列号
Sub 去重(sheetName As String, startRow As Long, colToCheck As Integer)
Dim ws As Worksheet
Dim lastRow As Long
' 设置要操作的工作表
Set ws = ThisWorkbook.Sheets(sheetName) ' 修改为你的表名
' 设置要检查重复项的列 (例如：1 = A列, 2 = B列, 3 = C列, 依此类推)
colToCheck = 1 ' 修改为你要检查的列号
' 找出该列的最后一行
lastRow = ws.Cells(ws.Rows.Count, colToCheck).End(xlUp).Row
' 确保起始行不超过最后一行
If startRow > lastRow Then
MsgBox "起始行大于数据的最后一行！", vbExclamation
Exit Sub
End If
' 删除重复项
ws.Range(ws.Cells(startRow, colToCheck), ws.Cells(lastRow, colToCheck)).RemoveDuplicates Columns:=1, Header:=xlNo
End Sub
Sub 批量执行()
' 刷新当前工作簿中的所有外部数据连接和数据透视表
' ThisWorkbook.RefreshAll
' 等待刷新操作完成
' Application.CalculateUntilAsyncQueriesDone
' 计算等待到的时间点，这里暂停 3 秒
Dim waitTime As Date
waitTime = Now + TimeValue("0:00:01")
' 让程序等待到指定时间
Application.Wait waitTime
Call 导入数据_数值("E:\数据\数据\新零售终端销售明细报表(营业员&厅).xls", "5G手机销量-渠道或营业厅", "AL1")
Call 导入指定区域数据_数值("E:\数据\数据\5G金币办理日清单报表.xls", 6, "A", "G", "5G日清单", "A6")
Call 导入指定区域数据_数值("E:\数据\数据\5G金币办理日清单报表.xls", 6, "H", "W", "5G日清单", "I6")
Call 导入指定区域数据_保留源文件格式("E:\数据\数据\主副卡关系.xlsx", 4, "A", "L", "带卡-主副卡关系", "A2")
Call 导入数据_保留源文件格式("E:\数据\数据\家庭账户-李雯.xlsx", "家庭账户", "A1")
Call 导入数据_保留源文件格式("E:\数据\数据\客户预存累计数据.xlsx", "客户预存", "D1")
Call 导入数据_保留源文件格式("E:\数据\数据\当月新入网.xlsx", "当月新入网", "B1")
Call 导入文本文档("E:\数据\数据\新入网-渠道.txt", "新入网 -渠道", "A1")
Call 导入文本文档("E:\数据\数据\新入网-营业厅.txt", "新入网 -营业厅", "A1")
Call 导入文本文档("E:\数据\数据\存量产能-渠道.txt", "存量产能（分列）", "A1")
Call 导入文本文档("E:\数据\数据\智家产品-渠道.txt", "智家产品", "A1")
Call 导入文本文档("E:\数据\数据\线盒-渠道.txt", "线盒", "A1")
Call 导入文本文档("E:\数据\数据\宽带-渠道.txt", "宽带新增", "A1")
Call 导入文本文档("E:\数据\数据\集团账户-渠道.txt", "集团账户", "B1")
Call 导入文本文档("E:\数据\数据\顺差-渠道.txt", "顺差-拉公式", "A1")
Call 导入文本文档("E:\数据\数据\泛升档-营业厅.txt", "泛升档", "A1")
Call 导入数据_保留源文件格式("E:\数据\数据\当月原套餐18+降档客户.xlsx", "降档挽留-当月原套餐18+", "A1")
waitTime = Now + TimeValue("0:00:03")
' 让程序等待到指定时间
Application.Wait waitTime
Call 拉公式_指定列("5G手机销量-渠道或营业厅", 6, "AL", 1, 37)
Call 拉公式_指定列("5G日清单", 6, "A", 25, 31)
Call 拉公式_指定列("客户预存", 2, "D", 1, 3)
Call 拉公式_指定列("客户预存", 2, "D", 15, 20)
Call 拉公式_指定列("当月新入网", 4, "B", 1, 1)
Call 拉公式_指定列("新入网 -营业厅", 2, "A", 14, 14)
Call 拉公式_指定列("新入网 -渠道", 2, "A", 10, 11)
Call 拉公式_指定列("集团账户", 2, "B", 1, 1)
Call 拉公式_指定列("顺差-拉公式", 2, "E", 6, 6)
Call 拉公式_指定列("泛升档", 2, "A", 14, 14)
Call 文本转数值("5G手机销量-渠道或营业厅", "AT", "AT")
Call 文本转数值("5G手机销量-渠道或营业厅", "AW", "AW")
Call 文本转数值("泛升档", "C", "C")
Call 文本转数值("5G日清单", "J", "J")
Call 文本转数值("5G日清单", "O", "O")
Set ws = ThisWorkbook.Sheets("渠道核心产能")
ws.Activate
End Sub
Sub 部分执行()
Call 导入数据_保留源文件格式("E:\数据\数据\当月新入网.xlsx", "当月新入网", "B1")
Call 拉公式_指定列("当月新入网", 4, "B", 1, 1)
End Sub
将以上vb宏修改为统信uos系统2023版WPS的可用js宏
本文介绍了一种使用Excel插件将文本型数字快速转换为数值型数字的方法。通过选中目标单元格并使用特定插件的功能，可以轻松实现转换。
扫一扫
3万+
到【灌水乐园】发言
