批量执行excel操作

zhaoxiaohao

我有一个文件夹，通过vba我已经能获得文件夹中的excel文件名，我想对每一个excel文件进行相同的操作，比方说单元格的拆分，行的移动等。具体的操作我也实现了。就是想知道怎样执行“批量”这个动作，不知大家明白我的意思吗？就是指定了某个文件，对他操作。再执行下一个文件，进行相同的操作。

Tq-laoyu

批量获取文件名并存入数组，然后循环操作每一个文件。

Tq-laoyu

为当前目录下的所有Excel文件设置打开权限密码：

Sub jiami()
Dim mypath As String, xlsname As String
Dim wbk As Workbook
mypath = ThisWorkbook.Path
xlsname = Dir(mypath & "\" & "*.xls")
Application.DisplayAlerts = False
Do While xlsname <> ""
    If xlsname <> ThisWorkbook.Name Then
        Set wbk = Workbooks.Open(mypath & "\" & xlsname)
        wbk.Password = "123456"
        wbk.Close savechanges:=True
    End If
    xlsname = Dir
Loop
Application.DisplayAlerts = False
End Sub

给你举个例子吧，这是我前一段时间给一哥们写的批量加密代码，不过这个例子不是用数组保存文件名，而是用遍历文件夹的方式操作文件（代码所在文件与被操作文件在同一目录下），不过效果是一样的。

zhaoxiaohao

我想还可以理解为当前的excel编写vba对另一个excel进行操作

cpljj

学习下，留个名，以后好查

LangQueS

建议楼主压缩上传Excel问题附件并加以说明或做出模拟结果，以便大家了解和解答。(编辑已发贴即可补充上传附件)

如何发表新话题和上传附件:
http://club.excelhome.net/thread-45649-1-1.html

发帖的技巧:
http://club.excelhome.net/thread-176339-1-1.html

zhaoxiaohao

谢谢各位了，我的问题是我的excel中有表格，表格有单元线，我想将某一列的单元线所围取的区域中的值移到该单元区的最顶端。附件和代码见http://club.excelhome.net/thread-453498-1-1.html
该问题已经解决，但是现在我要执行相同的操作对一批excel，所以想批量执行。
不知我描述的清楚了没有，谢谢各位了

Tq-laoyu

Sub jiami()
Dim mypath As String, xlsname As String
Dim wbk As Workbook
mypath = ThisWorkbook.Path
xlsname = Dir(mypath & "\" & "*.xls")
Application.DisplayAlerts = False
Do While xlsname <> ""
    If xlsname <> ThisWorkbook.Name Then
        Set wbk = Workbooks.Open(mypath & "\" & xlsname)
                with wbk.Sheets(1)
                         .......
                        ........
                        ........
                end with


        wbk.Close savechanges:=True
    End If
    xlsname = Dir
Loop
Application.DisplayAlerts = False
End Sub

zhaoxiaohao

谢谢了，自己在Tq-laoyu和大家的帮助下，终于算差不多了，其中也发现了些问题。还请大家多帮忙。我做了两个sub去调用
Sub Test()

Dim i As Integer
Dim strPath As String
Dim wbk As Workbook

strPath = "E:\xls"
'遍历文件夹
With Application.FileSearch
       .LookIn = strPath
       .SearchSubFolders = True
       .Filename = "*.*"
      If .Execute > 0 Then
         For i = 1 To .FoundFiles.Count
         Application.DisplayAlerts = False
               Range("A" & i) = .FoundFiles(i)
               Set wbk = Workbooks.Open(Range("A" & i).Text)
               Call MovingRow(wbk)
         Next i
      End If
End With
End Sub

Sub MovingRow(wb)
Dim irow As Integer
Dim i As Integer

Dim iTop As Integer

Dim sCol As String
Dim Str As String
Dim Stemp As String
Dim bFound As Boolean

iTop = 0

irow = wb.Sheets(1).UsedRange.Rows.Count
Str = ""
bFound = False
For i = 1 To irow
'判断姓名列
    If wb.Sheets(1).Cells(i, "C") = "姓名" Then
        sCol = "C"
    Else If wb.Sheets(1).Cells(i, "B") = "姓名" Then
        sCol = "B"
    End If
  
    With wb.Sheets(1).Range(sCol & i)
        wb.Sheets(1).Range(sCol & i).UnMerge
        Stemp = wb.Sheets(1).Cells(i, sCol)
        
        If .Borders(xlEdgeTop).LineStyle = 1 Then ‘上边框
            iTop = i
            Str = Str + Stemp
        ElseIf .Borders(xlEdgeBottom).LineStyle = 1 Then ’下边框,取得了一个人的数据
            If iTop <> 0 Then
                Str = Str + Stemp
                bFound = True
            End If
        Else ‘一个人中间的数据进行连接
            Str = Str + Stemp
        End If
        
        If bFound Then
            wb.Sheets(1).Cells(iTop, sCol) = Str
            Str = ""
            bFound = False
        Else
            wb.Sheets(1).Cells(i, sCol) = ""
        End If
              
            
        'If .Borders(xlEdgeLeft).LineStyle = 1 Then MsgBox "Left"
        'If .Borders(xlEdgeBottom).LineStyle = 1 Then MsgBox "Bottom"
        'If .Borders(xlEdgeRight).LineStyle = 1 Then MsgBox "Right"
    End With
Next i
wb.Close savechanges:=True
End Sub
发现的问题如下，本来不想用boolean的了，但是在.range下，好像还有.cell即使我限制了wb.Sheets(1).Cells(i, sCol)也同样取得的不是我想要的数据，cells(isCol).clear好像连格式也清空了，在这里就是我的单元格边框。

最后还想请问经过我这样赋值，字体改变了，怎样可以不改变字体。要是在with .range后面写.cells的话应怎样写

zhaoxiaohao

不好意思，好像有点乱说的。发现的问题如下
1、本来不想用boolean的了，但是在.range下，好像还有.cel属性，l即使我限制写成了wb.Sheets(1).Cells(i, sCol)也同样取得的数据不是我想要
2、原来想用cells(isCol).clear清空内容，但是发现好像连格式也清空了，是吧？在这里就是我的单元格边框清楚了。
3、最后还想请问经过我这样赋值，字体改变了，怎样可以不改变字体？
4、要是在with .range后面写.cells的话应怎样写