工作簿复制到文件夹

zy19880405

这里有个 总数据 文件夹，我希望打开这个文件夹下的每个工作簿   判断一下

如果工作簿的列是到K列为止的 那么这么工作簿就另存到 第一种表格 这个文件夹下

如果工作簿的列是到O列为止的 那么这么工作簿就另存到 第二种表格 这个文件夹下

如果工作簿的列是到AS列为止的 那么这么工作簿就另存到 第三种表格 这个文件夹下

实例文件就只有3个 实际上文件会有几百个。。求大神解决一下！

zy19880405

有大神帮忙解决一下么。。

zy19880405

顶一下~~求大神看看~~~

yxbaju

Sub fenlei()
'按照现有的三个文件夹分类，未写创建新文件夹代码（不删除创建好的即可），未写防止表名重复的文件移动（会报错），如需要请修改代码
      Dim sPath$, sNewpath$, sFilename$, sFullname$, rng As Range
      Dim fso
      Set fso = CreateObject("Scripting.FileSystemObject")
      sPath = ThisWorkbook.Path & "\"
      sFilename = Dir(sPath & "*.xlsx")
      Do While sFilename <> ""
            If sFilename <> ActiveWorkbook.Name Then
                  sFullname = sPath & sFilename
                  Set rng = GetObject(sFullname).Worksheets(1).Cells.SpecialCells(xlCellTypeLastCell)
                        sNewpath = Left(sPath, Len(sPath) - Len(Split(sPath, "\")(UBound(Split(sPath, "\")) - 1)) - 2) & "\"
                  If rng.Column = 11 Then Workbooks(sFilename).Close False: fso.movefile sFullname, sNewpath & "第一种表格\": GoTo 1
                  If rng.Column = 15 Then Workbooks(sFilename).Close False: fso.movefile sFullname, sNewpath & "第二种表格\": GoTo 1
                  If rng.Column = 45 Then Workbooks(sFilename).Close False: fso.movefile sFullname, sNewpath & "第三种表格\": GoTo 1
            End If
1:
            sFilename = Dir
      Loop
      MsgBox "完成"
End Sub