非常好的VBA编程问答

df888888

问题31：如何用Vba方法导出Xls文件至Txt文件？
即如何以一定的格式输出Excel文件的数据。
解答：
这是个常见的问题，因为许多不同应用系统之间报送数据时，最好的方法就是报送统一格式的数据文件，而带有特殊分割符号的文本文件应该说是最适用的。
下面的代码将输出的文件改为“文件名”+“Worksheet名”组合的TXT文件。代码的适当说明：生成Txt文件需要使用FileSystemObject对象，关于该对象的说明，可以参阅msdn或vba帮助中的相关内容。这段程序可以在将xls文件中任意的sheet中的内容导出成txt文本文件。
如下就是代码。可以将其复制到任何一个xls文件中。使用时，只要打开某个sheet，然后运行这个宏（菜单内：工具-〉宏-〉运行宏OutPutXlsToTxt），即可将该sheet内的数据导出生成TXT文件，文件名是由Excel文件名和Sheet名组合而成的。
‘***********************************
SubOutPutXlsToTxt()
  Dim fs, myFile As Object
  Dim i_row, i_col, i_MaxCol As Integer'xls工作表的行列坐标变量和最大列数变量
Dim myfileline As String'txtfile的行数据

  Set fs =CreateObject("Scripting.FileSystemObject")  '建立filesytemobject
'通过filesystemobject新建一个和xls文件同名的txt文件
  Set myFile =fs.createtextfile(Workbooks(1).Path + "\" + _
   Mid(Trim(Workbooks(1).Name), 1, Len(Trim(Workbooks(1).Name)) - 4) +"之" + _
   Trim(Workbooks(1).ActiveSheet.Name) +".txt")
  i_row = 1
  i_MaxCol = 0
  Do
    i_MaxCol =i_MaxCol + 1
  Loop Until Workbooks(1).ActiveSheet.Cells(1,i_MaxCol) = ""
  i_MaxCol = i_MaxCol -1   '获得整个sheet的最大列数
If i_MaxCol = 0Then      '对没有数据的表不做处理并退出程序
   MsgBox "该表无数据,不能导出!", vbCritical
    ExitSub
  End If
  Do
    myfileline =""
    For i_col =1 To i_MaxCol
     myfileline = myfileline + _
      Trim(CStr(Workbooks(1).ActiveSheet.Cells(i_row, i_col))) +"," '生成每行数据
   Next
   myFile.writeline (Mid(myfileline, 1, Len(myfileline) -1))  '将每行数据写入txtfile
   i_row = i_row + 1
  Loop Until Workbooks(1).ActiveSheet.Cells(i_row,1) = ""

  Set myFile = Nothing
  Set fs =Nothing                  '关闭文件和filesystemobject对象
End Sub
‘***********************************
= = = = = = = = = = = = = = = = = = = = = = = = = = = = = = == = = =
问题32：如何删除工作簿中的所有链接？
解答：可以用以下的代码来完成：
Sub RemoveHyperlinks()
Dim hl As Hyperlink
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Worksheets
   For Each hl Inws.Hyperlinks
     hl.Delete
  Next hl
Next ws
End Sub
= = = = = = = = = = = = = = = = = = = = = = = = = = = = = = == = = =
问题33：如何实现工程不可查看？
解答：使【工程不可查看】的两种实现方法：
在VBE里如何使自己的成果得到一定的保护呢?大家都知道,运用EXCEL本身提供的各级口令保护功能就可以对文档实施加密操作,可是这种口令保护十分脆弱(网上诸如此类暴力破解多如牛毛...).所以大多数VBE用户选择较多的就是如下这种加密方式(【工程不可查看】)：
方法一（共享级锁定）：
1、先对EXCEL文件进行一般的VBAProject工程密码保护。
2、打开要保护的文件，选择：工具--->保护--->保护并共享工作簿--->以追踪修订方式共享-->输入密码-->保存文件。
完成后，当你打开“VBAProject”工程属性时，就将会提示：“工程不可看！“
破解方法：用这种办法的话，只要找出工作表的密码保护，相应的工程就可以查看了，还不如用第二种方法的好!
方法二（推荐，破坏型锁定）：
用16进制编辑工具，如WinHex、Ultraedit-32等，再厉害点的人完全可以用debug命令来做......用以上软件打开EXCEL文件，查找定位以下地方：
ID="{00000000-0000-0000-0000-000000000000}"注：实际显示不会全部为0
此时，你只要将其中的字节随便修改一下即可。保存再打开，就会发现大功告成！
当然，在修改前最好做好你的文档备份。至于恢复只要将改动过的地方还原即可（只要你记住了呵呵）。
顺便说一句，这种方法仍然是可破解的，因为加密总是相对的。
破解方法：将CMG=，DPB=和GC=后的"="替换为"."也可以的，我已测试过的确可以。
= = = = = = = = = = = = = = = = = = = = = = = = = = = = = = == = = =
问题34：如何判断并根据条件删除行？
问题：有一个工作簿，其中有N张sheet，要做到：遍历所有sheet中指定列的值，如果该单元格的值为1，则什么都不做，如果为0，则删除此行。
解答：作下面的代码试试，注意，在试验之前先备份工作簿。
Sub DeleteRow(C As Integer)
  '指定一个列的数字，把所有工作表中该列数值为0的行删除
Dim sh As Worksheet
  Dim rg As Range
  For Each sh In ThisWorkbook.Worksheets
    Set rg =sh.Cells(65536, C).End(xlUp)
    Do Whilerg.Row >= 2
     If rg.Value = 0 Then
       Set rg = rg.Offset(-1, 0)
       rg.Offset(1, 0).EntireRow.Delete
     Else
       Set rg = rg.Offset(-1, 0)
     End If
    Loop
  Next
  Set sh=Nothing
  Set rg=Nothing
End Sub
= = = = = = = = = = = = = = = = = = = = = = = = = = = = = = == = = =

df888888

问题35：如何在不同的工作表之间进行复制？
问题：请问如何用函数将表格1自动复制至表格2对应的页？例如：我想将表格1对应的1、2、3、4复制至表格2对应1、2、3、4时，它会按要求自动复制，同时，当我想将表格1对应1、2复制至表格2对应1、2，表格1其余3、4不想同时复制，怎样可以做到呢？
解答：(陈希章)
至少有两个同时打开的工作簿，受保护的工作表不能被复制（自动被隐藏掉了）。
如图，在某个工作表中制作如下窗体：

相应代码如下：
Private Sub cb1_Change()
  Dim ws As Worksheet
  If cb1.ListIndex <> -1 Then
     Lst1.Clear
     For Each ws In Workbooks(cb1.Value).Worksheets
       If ws.ProtectContents = False Then Lst1.AddItem ws.Name
     Next
  Else
     Lst1.Clear
  End If
End Sub
Private Sub cb2_Change()
  Dim ws As Worksheet
  If cb2.ListIndex <> -1 Then
     lst2.Clear
     For Each ws In Workbooks(cb2.Value).Worksheets
       If ws.ProtectContents = False Then _
           lst2.AddItem ws.Name
     Next
  Else
     lst2.Clear
  End If
End Sub
Private Sub cmdadd_Click()
  Dim n As Integer
    IfLst1.ListIndex <> -1 And lst2.ListIndex <> -1Then
       If cb1.Value <> cb2.Value Then
           lst3.AddItem cb1.Value
           n = lst3.ListCount - 1
           lst3.List(n, 1) = Lst1.Value
           lst3.List(n, 2) = "=>"
           lst3.List(n, 3) = cb2.Value
           lst3.List(n, 4) = lst2.Value
           
       Else
           MsgBox "必须选择两个不同的工作簿", vbExclamation, "错误"
       End If
    Else
       MsgBox "必须先选择两个工作表", vbExclamation, "错误"
    End If
End Sub
Private Sub cmddelete_Click()
  Dim n As Integer
  n = lst3.ListIndex
  If n <> -1 Then
   lst3.RemoveItem n
  Else
    MsgBox"请先选择一个要删除的条件", vbExclamation, "错误"
  End If
End Sub
Private Sub cmdgo_Click()
    Dim n AsInteger, m As Integer
    Dim sws AsWorksheet, dws As Worksheet
    n =lst3.ListCount
    If n > 0Then
       For m = 0 To n - 1
           Set sws = Workbooks(lst3.List(m, 0)).Worksheets(lst3.List(m,1))
           Set dws = Workbooks(lst3.List(m, 3)).Worksheets(lst3.List(m,4))
           sws.Cells.Copy dws.Cells
       Next
       MsgBox "复制完毕", vbInformation, "报告"
    Else
       MsgBox "没有需要执行的任务", vbExclamation, "错误"
    End If
End Sub
Private Sub CommandButton2_Click()
    UnloadMe
End Sub
Private Sub UserForm_Initialize()
  Dim wb As Workbook
  Dim n As Integer
  n = Application.Workbooks.Count
  If n = 1 Then
    cb1.Enabled= False
    cb2.Enabled= False
    Lst1.Enabled= False
    lst2.Enabled= False
   cmdadd.Enabled = False
   cmddelete.Enabled = False
   cmdgo.Enabled = False
    MsgBox"当前只有一个工作簿", vbExclamation, "错误"
    ExitSub
  Else
    For Each wbIn Application.Workbooks
       cb1.AddItem wb.Name
    Next
    cb1.Value =ThisWorkbook.Name
    cb2.List =cb1.List
  End If
End Sub
= = = = = = = = = = = = = = = = = = = = = = = = = = = = = = == = = =
问题36：如何在打开工作簿时自动运行宏?
解答：通过Workbook_Open事件，有两种基本的方法可以运行/执行宏代码，见下面的示例：
Private Sub Workbook_Open()
    MsgBox"您好!", vbInformation, "fanjy.blog.excelhome.net"
End Sub
也可以通过下面的方式：
Private Sub Workbook_Open()
    Run"MyMacro"
End Sub
Private Sub MyMacro()
   MsgBox "您好", vbInformation,"fanjy.blog.excelhome.net"
End Sub
但是MyMacro宏程序必须处于任何其它独立的模块(即“插入>>模块”)，不能与Work_Open事件在同一模块中。如果想在同一Private模块中，则不能使用Run语句，只使用程序名，如：
Private Sub Workbook_Open()
   MyMacro
End Sub
Private Sub MyMacro()
   MsgBox "您好", vbInformation,"fanjy.blog.excelhome.net"
End Sub
- - - - - - - - - - - - - - - - -- - - - - - - - - - - - - - - - - - - - - - -
问题37：如何在指定的时间或指定的间隔运行宏?
解答：有时想在预定的时间运行宏或在指定的间隔运行宏，则可以使用Application对象的OnTime方法来实现。例如，如果想在每天下午15:00运行某个宏，可以将代码放在Work_Open事件中：
Private Sub Workbook_Open()
  Application.OnTime TimeValue("15:00:00"),"MyMacro"
End Sub
“MyMacro”是想运行的宏名，放置在单独的模块中，也有OnTime方法：
Sub MyMacro()
  Application.OnTime TimeValue("15:00:00"),"MyMacro"
'<在这里放置代码>
End Sub
此时，将在每天下午15点运行MyMacro过程。
如果想在打开工作簿后，每隔15分钟运行MyMacro宏，则可以在ThisWorkbook模块中输入下面的代码：
Private Sub Workbook_BeforeClose(Cancel As Boolean)
  Application.OnTime dTime, "MyMacro", ,False
End Sub
Private Sub Workbook_Open()
  Application.OnTime Now + TimeValue("00:15:00"),"MyMacro"
End Sub
然后，在独立的模块中，输入下面的代码：
Public dTime As Date
Sub MyMacro()
  dTime = Now + TimeValue("00:15:00")
  Application.OnTime dTime, "MyMacro"
'<在这里放置代码>
End Sub
- - - - - - - - - - - - - - - - -- - - - - - - - - - - - - - - - - - - - - - -

df888888

问题38：如何从Excel中发送E-Mail?
解答：在ExcelVBA中可以发送电子邮件，甚至可以将工作簿作为附件。
SendMail方法
SendMail方法很容易使用且将任何指定的Excel工作簿作为附件发送给特定的客户端，将下面的代码存放在Personal.xls工作簿中：
Sub SendActiveWorkbook()
   ActiveWorkbook.SendMail _
   Recipients:="xhdsxfjy@163.com", _
   Subject:="试一试" & Format(Date, "dd/mmm/yy")
End Sub
如果仅想发送工作簿中的一个工作表，则可以使用下面的代码。该代码创建一个包含该工作表的一个新工作簿，然后将它作为附件发送，最后不保存而关闭该工作簿。
Sub Send1Sheet_ActiveWorkbook()
'创建一个包含一个工作表的新工作簿作为电子邮件的附件
  ThisWorkbook.Sheets(1).Copy
  With ActiveWorkbook
    .SendMailRecipients:="xhdsxfjy@163.com", _
    Subject:="试一试" & Format(Date, "dd/mmm/yy")
    .CloseSaveChanges:=False
  End With
End Sub
Route方法
Route方法可以指定许多客户端，使工作簿按规定路线一个接一个发送给收件人。在发送时，文本自动添加到email的主体中。可以从Excel的“文件”菜单中选择“发送”命令，然后选择“传送收件人”，再选择下一个传送的客户端。
下面的代码将首先传送给xhdsxfjy@163.com，接着转到Excel菜单“文件>>发送>>下一个传送收件人”，工作簿将自动传送到下一个客户fan_jinyong@hotmail.com。
Sub RouteActiveWorkbook()
    WithActiveWorkbook
      .HasRoutingSlip = True
          With .RoutingSlip
               .Delivery = xlOneAfterAnother
               .Recipients = Array("xhdsxfjy@163.com", _
                   "fan_jinyong@hotmail.com","exceltrainer2003@yahoo.com.cn")
               .Subject = "请检查"
               .Message = "请填写工作簿并发送."
         End With
       .Route
    EndWith
End Sub
- - - - - - - - - - - - - - - - -- - - - - - - - - - - - - - - - - - - - - - -
问题39：如何删除重复值?
解答：
(1)使用高级筛选删除重复值
使用Excel的高级筛选功能删除重复值可能是最快的方法。下面的代码对列A中的数据进行操作：
Sub RemoveDupes()
   '在列A左边添加一列,则原来的列A成为列B
   Columns(1).EntireColumn.Insert
   
   '筛选掉重复的值并将不重复的值复制到列A
    Range("B1",Range("B65536").End(xlUp)).AdvancedFilter _
       Action:=xlFilterCopy, CopyToRange:=Range("A1"), Unique:=True
   '删除掉有重复值的列
   Columns(2).EntireColumn.Delete
End Sub
(2)从任何单元格区域删除重复值
下面的代码将删除所选数据区域里的重复值：
Sub KillDupes()
  Dim rConstRange As Range, rFormRange AsRange
  Dim rAllRange As Range, rCell As Range
  Dim iCount As Long
  Dim strAdd As String
  On Error Resume Next
  Set rAllRange = Selection
  If WorksheetFunction.CountA(rAllRange) < 2Then
    MsgBox"所选区域无效", vbInformation
    On ErrorGoTo 0
    ExitSub
  End If
  Set rConstRange =rAllRange.SpecialCells(xlCellTypeConstants)
  Set rFormRange =rAllRange.SpecialCells(xlCellTypeFormulas)
  If Not rConstRange Is Nothing And NotrFormRange Is Nothing Then
    SetrAllRange = Union(rConstRange, rFormRange)
  ElseIf Not rConstRange Is Nothing Then
    SetrAllRange = rConstRange
  ElseIf Not rFormRange Is Nothing Then
    SetrAllRange = rFormRange
  Else
    MsgBox"所选区域无效", vbInformation
    On ErrorGoTo 0
    ExitSub
  End If
  
  Application.Calculation =xlCalculationManual
  For Each rCell In rAllRange
    strAdd =rCell.Address
    strAdd =rAllRange.Find(What:=rCell, After:=rCell, LookIn:=xlValues, _
       LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext,_
       MatchCase:=False).Address
    If strAdd<> rCell.Address Then
     rCell.Clear
    End If
  Next rCell

  Application.Calculation =xlCalculationAutomatic
  On Error GoTo 0
End Sub
- - - - - - - - - - - - - - - - -- - - - - - - - - - - - - - - - - - - - - - -
问题40：如何获取命名单元格区域的地址？
解答：Excel有一个方便的内置功能，能够创建一个所有命名区域列表和相对应的区域地址。这能够通过菜单“插入>>名称>>粘贴”命令来实现，此时会弹出一个名为“粘贴名称”的对话框，如下图所示，然后单击“粘贴列表”按钮。

但这种方法有一个缺点就是不能动态改变列表，当名称改变后，必须重新执行上述操作来更新单元格区域地址。可以自定义函数来动态改变命名列表。
假设有一个名为“MyNumbers”的单元格区域，该区域引用工作表Sheet1中的单元格区域A1：A10，可以使用下面的自定义函数：
=RangeNameAddress(MyNumbers)
或者：
=RangeNameAddress(MyNumbers,0)
将会返回$A$1:$A$10。
或者：
=RangeNameAddress(MyNumbers,1)
或者：
=RangeNameAddress(MyNumbers,True)
将会返回Sheet1$A$1:$A$10。
该自定义函数的代码如下：
Function RangeNameAddress(Range_Name _
         As Range, Optional SheetName As Boolean) As String
              
    Dim strNameAs String
   Application.Volatile
    IfSheetName = True Then
       strName = "'" & Range_Name.Parent.Name & "'!" & _
       Range_Name.Address
    Else
       strName = Range_Name.Address
    End If
  
   RangeNameAddress = strName
End Function

feng474

谢谢分享，收藏了，慢慢学习！

飞云楼主

谢谢分享，学习了

李巴

好东西，先留印再看

zez

谢谢!楼主辛苦

枫桥夜泊lwb

看不懂但先下载了再学习

FXSHENG

感谢分享
收藏学习
原文件上传的话不错，如做成PDF文件的话更好，有点贪了

[ 本帖最后由 FXSHENG 于 2010-8-17 11:33 编辑 ]

changanjun

阅读收藏了！致谢，致敬！