我明白你的代码是否正确,从目标文件夹中读取所有的文件,纸张问题是,你只需要提取一个Sheet
名为每个文件Data
,所以如果是这样的话试试这个:
编辑只包括选定的列提取!
方法:复制目标工作
Sub SaveToCSVs()
Const kWshName As String = "Data"
Dim sPathInp As String, sPathOut As String
Dim sPathFile As String, sCsvFile As String
Dim WbkSrc As Workbook, WshSrc As Worksheet
Dim WbkCsv As Workbook, WshCsv As Worksheet
Dim rData As Range
sPathInp = "C:\temp\pydev\"
sPathOut = "C:\temp\"
sPathFile = Dir(sPathInp)
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Do While (sPathFile <> "")
If Right(sPathFile, 4) = ".xls" Or Right(sPathFile, 5) = ".xlsx" Then
Rem Initialize Objects
Set WbkSrc = Nothing
Set WshSrc = Nothing
Rem Set Objects
On Error Resume Next
Set WbkSrc = Workbooks.Open(sPathInp & sPathFile)
If Not (WbkSrc Is Nothing) Then
Set WshSrc = WbkSrc.Sheets(kWshName)
If Not (WshSrc Is Nothing) Then
On Error GoTo 0
Rem Set Csv Filename
sCsvFile = Left(sPathFile, -1 + InStrRev(sPathFile, "."))
sCsvFile = sCsvFile & " - " & kWshName
Rem Calculate, Unhide Rows & Columns & Copy Data Sheet
With WshSrc
.Calculate
.Cells.EntireRow.Hidden = False
.Cells.EntireColumn.Hidden = False
.Copy
End With
Set WshCsv = ActiveSheet
Rem Delete All Other Columns
With Range(WshCsv.Cells(1), WshCsv.UsedRange.SpecialCells(xlLastCell))
.Value = .Value
Set rData = Union(Columns("A"), Columns("P"), Columns("AC"))
rData.EntireColumn.Hidden = True
.SpecialCells(xlCellTypeVisible).EntireColumn.Delete
rData.EntireColumn.Hidden = False
End With
Rem Save as Csv
WshCsv.SaveAs Filename:=sPathOut & sCsvFile, FileFormat:=xlCSV
WshCsv.Parent.Close
WbkSrc.Close
End If: End If: End If
sPathFile = Dir
On Error GoTo 0
Loop
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
End Sub
方法:打开工作簿为只读
Sub SaveToCSVs()
Const kWshName As String = "Data"
Dim sPathInp As String
Dim sPathOut As String
Dim sPathFile As String
Dim sCsvFile As String
Dim WbkSrc As Workbook
Dim WshSrc As Worksheet
Dim rData As Range
sPathInp = "C:\temp\pydev\"
sPathOut = "C:\temp\"
sPathFile = Dir(sPathInp)
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Do While (sPathFile <> "")
If Right(sPathFile, 4) = ".xls" Or Right(sPathFile, 5) = ".xlsx" Then
Rem Initialize Objects
Set WbkSrc = Nothing
Set WshSrc = Nothing
Rem Set Objects
On Error Resume Next
Set WbkSrc = Workbooks.Open(Filename:=sPathInp & sPathFile, ReadOnly:=True)
If Not (WbkSrc Is Nothing) Then
Set WshSrc = WbkSrc.Sheets(kWshName)
If Not (WshSrc Is Nothing) Then
On Error GoTo 0
Rem Set Csv Filename
sCsvFile = Left(sPathFile, -1 + InStrRev(sPathFile, "."))
sCsvFile = sCsvFile & " - " & kWshName
Rem Calculate, Unhide Rows & Columns & Copy Data Sheet
With WshSrc
.Calculate
.Cells.EntireRow.Hidden = False
.Cells.EntireColumn.Hidden = False
Rem Delete All Other Columns
With Range(.Cells(1), .UsedRange.SpecialCells(xlLastCell))
.Value = .Value
Set rData = Union(Columns("A"), Columns("P"), Columns("AC"))
rData.EntireColumn.Hidden = True
.SpecialCells(xlCellTypeVisible).EntireColumn.Delete
rData.EntireColumn.Hidden = False
End With: End With
Rem Save as Csv
WshSrc.SaveAs Filename:=sPathOut & sCsvFile, FileFormat:=xlCSV
WbkSrc.Close
End If: End If: End If
sPathFile = Dir
On Error GoTo 0
Loop
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
End Sub
来源
2016-11-05 07:34:01
EEM
我居然因此未对我自己写的,但我还是把帮助从下面的代码 –
子SaveToCSVs() Dim fDir As String Dim wB As Workbook Dim wS作为工作表 昏暗fPath作为字符串 昏暗SPATH作为字符串 fPath = “C:\ TEMP \的PyDev \” SPATH = “C:\ TEMP \” FDIR = DIR(fPath) 的do while(FDIR <> “” ) If Right(fDir,4)=“.xls”或Right(fDir,5)=“.xlsx”然后 On Error Resume Next 设置wB = Workbooks.Open(fPath&fDir) 对于每个wS在wB .Sheets wS.SaveAs SPATH&wS.Name,xlCSV 下一步WS wB.Close假 设置白平衡=无 结束如果 FDIR = DIR 对错误转到0 环路 End Sub –
我不知道如何在这里以适当的格式写上述..我是这个新手 –