Excel VBA Странная проблема - PullRequest
Новая
       5

Excel VBA Странная проблема

0 голосов
/ 26 сентября 2018

Сценарий 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 голосов
/ 26 сентября 2018

Я предполагаю, что книги с ошибками на самом деле имеют несколько листов.Обратите внимание на оператор For Each ws In wB.Sheets в верхней части кода.Этот цикл завершается хорошо внизу кода.Если есть несколько листов, ws определенно не всегда будет указывать на активный лист.

Если вы всегда хотите работать только с активным листом, полностью удалите цикл и измените эти строки в своем коде

1006

К 

DataLastRow = Cells(ws.Rows.Count, "A").End(xlUp).Row
SheetLastRow = Cells.SpecialCells(xlLastCell).Row
.
.
.
SaveAs sPath & NameOfWorkbook & ".csv", xlCSV
Добро пожаловать на сайт PullRequest, где вы можете задавать вопросы и получать ответы от других членов сообщества.

Нет похожих вопросов

...