ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

搜索
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 效率神器,一键搞定繁琐工作
HR薪酬管理数字化实战 Excel 2021函数公式学习大典 Excel数据透视表实战秘技 打造核心竞争力的职场宝典
让更多数据处理,一键完成 数据工作者的案头书 免费直播课集锦 ExcelHome出品 - VBA代码宝免费下载
用ChatGPT与VBA一键搞定Excel WPS表格从入门到精通 Excel VBA经典代码实践指南
查看: 1636|回复: 3

[分享] 格式转换小工具 将指定列指行以下值转换成文本格式

[复制链接]

TA的精华主题

TA的得分主题

发表于 2018-7-12 11:06 | 显示全部楼层 |阅读模式
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
本帖最后由 盘尼西林99 于 2018-7-12 15:00 编辑

适用范围:工作表头比较复杂且不允许更改者
一般情况,推荐使用Excce自带的“分列”等功能

Option Explicit
Sub 将某列指定区域设置成文本格式()
Rem 2018年7月12日完成
MsgBox "为防止误操作,请务必做好规划!" & vbCrLf & vbCrLf & "咨询电话:139  ****  9780", , "文本格式设置"

Application.ScreenUpdating = False
Application.DisplayAlerts = False

Rem 选择工作簿
Dim wb
    wb = Application.GetOpenFilename("Excel 文件 ,*.xls*;*.xlsx")
        If wb = False Then MsgBox "未选择文件!":   Exit Sub     
    Workbooks.Open (wb)
   
Rem 输入需查找的工作表名
Dim sh As String
100:
    sh = InputBox("请输入要查找的工作表名:", "输入提示", "Sheet2")
On Error Resume Next
If Sheets(sh) Is Nothing Then MsgBox "未输入表名或工作表不存在!", vbOKOnly: GoTo 100

Sheets(sh).Select

Rem 输入起始行号
Dim sr
On Error Resume Next
200:
sr = Val(InputBox("请输入起始行号", "输入提示", 2))
    If Not (sr > 0 And sr = Int(sr)) Then
        MsgBox "你没有输入行号或输入的不是正整数,请重新输入!", 64 + 1, "温馨提示"
        GoTo 200
    End If


Rem 输入需转换内容的列号
Dim sc
On Error Resume Next
300:
sc = Val(InputBox("请输入转换列号", "输入提示", 2))
    If Not (sc > 0 And sc = Int(sc)) Then
        MsgBox "你没有输入列号或输入的不是正整数,请重新输入!", 64 + 1, "温馨提示"
        GoTo 300
    End If


Rem 为提高速度,利用数组,在指定列指定行以下添加“'”号,使其变成文本格式
Dim arr
Dim j
    arr = Range(Cells(sr, sc), Cells(Cells(Rows.Count, sc).End(3).Row, sc))    '相当于arr =Range("A2:A" & i)
    For j = 1 To UBound(arr)
        arr(j, 1) = "'" & arr(j, 1)        '加上一个“'”,使其变成文本格式
    Next
   
    Cells(sr, sc).Resize(UBound(arr), 1) = arr
   
ActiveWorkbook.Close SaveChanges:=True   ' 如果要避免出现提示,可添加“SaveChanges”参数,直接保存并关闭工作簿
    MsgBox "完工!请查验!", 64, "友情提示"
Application.ScreenUpdating = True '恢复屏幕刷新
Application.DisplayAlerts = True  '恢复显示系统警告和消息
   
    ThisWorkbook.Saved = True
    Application.Quit
End Sub


将指定列指定行以下值转换成文本格式.rar

14.13 KB, 下载次数: 33

评分

1

查看全部评分

TA的精华主题

TA的得分主题

 楼主| 发表于 2018-7-12 11:10 | 显示全部楼层
本帖最后由 盘尼西林99 于 2018-7-12 15:03 编辑

不好意思,上传不了附件
已上传  2018-7-12 15:00

TA的精华主题

TA的得分主题

发表于 2018-7-12 11:27 | 显示全部楼层

TA的精华主题

TA的得分主题

 楼主| 发表于 2018-7-12 15:02 | 显示全部楼层
wangweihebtu 发表于 2018-7-12 11:27
压缩成压缩包就可以了

谢谢,附件已上传。
上午也做过压缩,但没法上传。
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2025-1-9 00:07 , Processed in 0.045161 second(s), 15 queries , Gzip On, MemCache On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

沪公网安备 31011702000001号 沪ICP备11019229号-2

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:李志群律师

快速回复 返回顶部 返回列表