将单个工作表另存为CSV并删除包含特定文本的行

时间:2017-08-24 00:03:19

标签: excel vba csv rows

我已尽力浏览整个网站以获得答案,但没有任何运气 - 或者我不确切知道我在寻找什么。

我的问题是我有一张4张的XL工作簿;一个将保存原始数据,另外三个将使用VLookup来填充表格 - 这很好。 现在我运行VBA宏:

表格应该做的事情如下:

1:获取工作簿中每个工作表的内容,并将每个工作簿保存为CSV 2:运行A1:A1000,如果找到单词NUKE,则删除entier行。 3:再次保存工作表。

可能会遇到的一个问题是数据被复制为公式,但工作表的保存就是值。

编辑: 我道歉,我没有提到我遇到的问题。行未删除。

Public Sub SaveWorksheetsAsCsv()
    Dim WS As Worksheet
    Dim SaveToDirectory As String, newName As String

    SaveToDirectory = "C:\jgd\"

    For Each WS In ThisWorkbook.Worksheets
        newName = GetBookName(ThisWorkbook.Name) & "_" & WS.Name
        WS.Copy
        ActiveWorkbook.SaveAs SaveToDirectory & newName, xlCSV
        Call RemoveRows
        ActiveWorkbook.Close Savechanges:=True
    Next
    Call Msg_exe
End Sub

Function GetBookName(strwb As String) As String
    GetBookName = Left(strwb, (InStrRev(strwb, ".", -1, vbTextCompare) - 1))
End Function

Sub CheckDir()

    Dim strPath  As String
    Dim lCtr     As Long

    strPath = "C:\jgd\"

    arrpath = Split(strPath, "\")
    strPath = arrpath(LBound(arrpath)) & "\"

    For lCtr = LBound(arrpath) + 1 To UBound(arrpath)
        strPath = strPath & arrpath(lCtr) & "\"
        If Dir(strPath, vbDirectory) = "" Then
            MkDir strPath
        End If
    Next
    Call SaveWorksheetsAsCsv
End Sub

Sub RemoveRows()

Dim i As Long
i = 1

Do While i <= ThisWorkbook.ActiveSheet.Range("A1").CurrentRegion.Rows.Count
    If InStr(1, ThisWorkbook.ActiveSheet.Cells(i, 1).Text, "NUKE", vbTextCompare) > 0 Then
        ThisWorkbook.ActiveSheet.Rows(i).EntireRow.Delete
    Else
        i = i + 1
    End If
Loop

End Sub
Sub Msg_exe()
    Dim Ret_type As Integer
    Dim strMsg As String
    Dim strTitle As String
    strMsg = "Conversion is complete." & vbCrLf & "Do you want to open the destination folder?"
    strTitle = "Conversion Complete"
        Ret_type = MsgBox(strMsg, vbYesNo + vbQuestion, strTitle)
        Select Case Ret_type
            Case 6
                Call Shell("explorer.exe" & " " & "c:\jgd", vbNormalFocus)
        End Select
End Sub

非常感谢任何帮助。

0 个答案:

没有答案