Excel VBA古怪问题

时间：2018-09-26 19:37:46

标签： excel-vba csv

Excel脚本从文件目录中删除空记录（空白行（、、、、、、、、、、、、、、、、），并另存为csv。在80个随机文件中，它会删除除标题行之外的所有行。有任何想法吗。调试使我进入下面的代码，最后一行是进行删除的地方，但是看起来它绝对适用于所有文件，而def对于大多数文件都适用。

不存在合并的列，也没有奇怪的格式。

编辑以显示完整脚本：（警告：此刻非常丑陋（调试和情况））

Sub SaveToCSVs()
Dim fDir As String
Dim wB As Workbook
Dim ws As Worksheet
Dim fPath As String
Dim sPath As String
Dim LastRow As Long
Dim cell As Range
Dim cellMid As Range
Dim MiddleName As String
Dim MiddleNameColumn As ListColumn
Dim d As Double
Dim C As Range

Dim LR As Long, i As Long

fPath = "C:\PPEAug\Rosters EMP ID\"
sPath = "C:\PPEAug\Rosters EMP ID\Converted\"
fDir = Dir(fPath)

Do While (fDir <> "")

If Right(fDir, 4) = ".xls" Or Right(fDir, 5) = ".xlsx" Then

On Error Resume Next
    Set wB = Workbooks.Open(fPath & fDir)
    Set ws = wB.ActiveSheet
    Set objExcel = CreateObject("Excel.Application")
    objExcel.Visible = False
    objExcel.DisplayAlerts = False
    Application.DisplayAlerts = False

For Each ws In wB.Sheets


With Range("A:Z")
    .Value2 = Evaluate("INDEX(Trim(" & .Address(0, 0) & "),,)")
    End With

Columns("D:D").Select
    Selection.Replace What:="-", Replacement:="", LookAt:=xlPart, _
    SearchOrder:=xlByColumns, MatchCase:=False, SearchFormat:=False, _
    ReplaceFormat:=False
    Range("D2:D5000").Select

Dim rg As Range
    For Each rg In Selection
    rg.NumberFormat = "@"
    If Len(rg.Value) < 12 And Len(rg.Value) > 0 Then
    rg.Value = WorksheetFunction.Rept("0", 12 - Len(rg.Value)) & rg.Value
End If
Next

Columns("E:E").Select
    Set rg = Selection
    rg.NumberFormat = "000-00-0000"

Columns("I:I").Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove

Columns("J:J").Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove

Columns("H:H").Select
    Selection.TextToColumns Destination:=Range("H1"), DataType:=xlDelimited, _
    TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=True, _
    Semicolon:=False, Comma:=False, Space:=True, Other:=False, FieldInfo _
    :=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=True

Columns("H:H").Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove

Columns("H:H").Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove



        Columns("G:G").Select
Selection.Replace What:=" ", Replacement:="-", LookAt:=xlPart, _
    SearchOrder:=xlByColumns, MatchCase:=False, SearchFormat:=False, _
    ReplaceFormat:=False
Selection.Replace What:="-JR", Replacement:=" JR", LookAt:=xlPart, _
    SearchOrder:=xlByColumns, MatchCase:=False, SearchFormat:=False, _
    ReplaceFormat:=False
Selection.Replace What:="-SR", Replacement:=" SR", LookAt:=xlPart, _
    SearchOrder:=xlByColumns, MatchCase:=False, SearchFormat:=False, _
    ReplaceFormat:=False
Selection.Replace What:="-II", Replacement:=" II", LookAt:=xlPart, _
    SearchOrder:=xlByColumns, MatchCase:=False, SearchFormat:=False, _
    ReplaceFormat:=False
Selection.Replace What:="-III", Replacement:=" III", LookAt:=xlPart, _
    SearchOrder:=xlByColumns, MatchCase:=False, SearchFormat:=False, _
    ReplaceFormat:=False
Selection.Replace What:="-IV", Replacement:=" IV", LookAt:=xlPart, _
    SearchOrder:=xlByColumns, MatchCase:=False, SearchFormat:=False, _
    ReplaceFormat:=False
Selection.Replace What:=".", Replacement:="", LookAt:=xlPart, _
    SearchOrder:=xlByColumns, MatchCase:=False, SearchFormat:=False, _
    ReplaceFormat:=False
Selection.Replace What:=", ", Replacement:=" ", LookAt:=xlPart, _
    SearchOrder:=xlByColumns, MatchCase:=False, SearchFormat:=False, _
    ReplaceFormat:=False
Selection.Replace What:=",", Replacement:=" ", LookAt:=xlPart, _
    SearchOrder:=xlByColumns, MatchCase:=False, SearchFormat:=False, _
    ReplaceFormat:=False
    Dim rCell As Range, strChar As String
    strChar = "-"

Columns("B:B").Select
    Selection.Replace What:="'", Replacement:="", LookAt:=xlPart, _
    SearchOrder:=xlByColumns, MatchCase:=False, SearchFormat:=False, _
    ReplaceFormat:=False

Range("G1").Select
    ActiveCell.FormulaR1C1 = "LAST NAME"

Columns("G:G").Select
    Selection.TextToColumns Destination:=Range("G1"), DataType:=xlDelimited, _
    TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=True, _
    Semicolon:=False, Comma:=False, Space:=True, Other:=False, FieldInfo _
    :=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=True

For Each cell In Range("$A$1:" & Range("$A$1").SpecialCells(xlLastCell).Address)
    If Len(cell) > 0 Then cell = UCase(cell)
Next cell
Range("A1").Select
    ActiveCell.FormulaR1C1 = "AFFILIATE"
Range("B1").Select
    ActiveCell.FormulaR1C1 = "PPE"
Range("C1").Select
    ActiveCell.FormulaR1C1 = "DUES AMT"
Range("D1").Select
    ActiveCell.FormulaR1C1 = "EMP ID"
Range("E1").Select
    ActiveCell.FormulaR1C1 = "SSN"
Range("F1").Select
    ActiveCell.FormulaR1C1 = "DOB"
Range("G1").Select
    ActiveCell.FormulaR1C1 = "LAST NAME"
Range("H1").Select
    ActiveCell.FormulaR1C1 = "NAME SUFFIX"
Range("I1").Select
    ActiveCell.FormulaR1C1 = "PlaceHolder"
Range("J1").Select
    ActiveCell.FormulaR1C1 = "FIRST NAME"
Range("K1").Select
    ActiveCell.FormulaR1C1 = "MIDDLE NAME"
Range("L1").Select
    ActiveCell.FormulaR1C1 = "SECOND MIDDLE"
Range("M1").Select
    ActiveCell.FormulaR1C1 = "ADDRESS 1"
Range("N1").Select
    ActiveCell.FormulaR1C1 = "ADDRESS 2"
Range("O1").Select
    ActiveCell.FormulaR1C1 = "CITY"
Range("P1").Select
    ActiveCell.FormulaR1C1 = "STATE"
Range("Q1").Select
    ActiveCell.FormulaR1C1 = "ZIP"
Columns("I:I").Select
    Selection.Replace What:=".", Replacement:="", LookAt:=xlPart, _
    SearchOrder:=xlByColumns, MatchCase:=False, SearchFormat:=False, _
    ReplaceFormat:=False

Columns("A:A").Select
    Selection.Replace What:="L", Replacement:="l", LookAt:=xlPart, _
    SearchOrder:=xlByColumns, MatchCase:=True, SearchFormat:=False, _
    ReplaceFormat:=False
    Selection.Replace What:="A", Replacement:="a", LookAt:=xlPart, _
    SearchOrder:=xlByColumns, MatchCase:=True, SearchFormat:=False, _
    ReplaceFormat:=False
    Selection.Replace What:="B", Replacement:="b", LookAt:=xlPart, _
    SearchOrder:=xlByColumns, MatchCase:=True, SearchFormat:=False, _
    ReplaceFormat:=False

Range("A1").Select
    ActiveCell.FormulaR1C1 = "AFFIlIATE"



Columns("G:G").Select
    For Each C In Selection
    If Right(C.Value, 1) = "-" Then
    C.Value = Left(C.Value, Len(C.Value) - 1)
End If
Next C
Columns("G:G").Select
    For Each C In Selection
    If Right(C.Value, 1) = "-" Then
    C.Value = Left(C.Value, Len(C.Value) - 1)
End If
Next C
Columns("H:H").Select
    For Each C In Selection
    If Right(C.Value, 1) = "-" Then
    C.Value = Left(C.Value, Len(C.Value) - 1)
End If
Next C
Columns("H:H").Select
    For Each C In Selection
    If Right(C.Value, 1) = "-" Then
    C.Value = Left(C.Value, Len(C.Value) - 1)
End If
Next C
Columns("J:J").Select
    For Each C In Selection
    If Right(C.Value, 1) = "-" Then
    C.Value = Left(C.Value, Len(C.Value) - 1)
End If
Next C
Columns("J:J").Select
    For Each C In Selection
    If Right(C.Value, 1) = "-" Then
    C.Value = Left(C.Value, Len(C.Value) - 1)
End If
Next C
Columns("K:K").Select
    For Each C In Selection
    If Right(C.Value, 1) = "-" Then
    C.Value = Left(C.Value, Len(C.Value) - 1)
End If
Next C
Columns("K:K").Select
    For Each C In Selection
    If Right(C.Value, 1) = "-" Then
    C.Value = Left(C.Value, Len(C.Value) - 1)
End If
Next C

Range("A1").Select
    Application.CutCopyMode = False

'DataLastRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row
'SheetLastRow = ws.Cells.SpecialCells(xlLastCell).Row
'ws.Rows(DataLastRow + 1 & ":" & SheetLastRow).Delete

NameOfWorkbook = Left(wB.Name, (InStrRev(wB.Name, ".", -1, vbTextCompare) - 1))
ws.SaveAs sPath & NameOfWorkbook & ".csv", xlCSV
Next ws
wB.Close False
Set wB = Nothing

    End If

    fDir = Dir
    On Error GoTo 0
Loop
MsgBox "PPE Roster Conversion Completed." 
End Sub

1 个答案:

答案 0 :(得分：0)

我的猜测是，失败的工作簿实际上有多张纸。请注意代码顶部的For Each ws In wB.Sheets语句。该循环在代码底部附近完全完成。如果有多个工作表，ws绝对不会总是指向活动的工作表。

如果您始终只希望使用活动工作表，请完全删除循环并在代码中更改以下行：

DataLastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
SheetLastRow = ws.Cells.SpecialCells(xlLastCell).Row
.
.
.
ws.SaveAs sPath & NameOfWorkbook & ".csv", xlCSV

收件人

DataLastRow = Cells(ws.Rows.Count, "A").End(xlUp).Row
SheetLastRow = Cells.SpecialCells(xlLastCell).Row
.
.
.
SaveAs sPath & NameOfWorkbook & ".csv", xlCSV
相关问题
最新问题