Excel VBA，可打开，复制/粘贴，格式化单元格并用if条件替换值，并保存文件

时间：2020-07-28 16:57:54

标签： excel vba

我有由两部分组成的代码，该函数检查文件是否存在具有固定名称的文件，如果不存在，则创建该文件，如果存在，则仅在文件末尾添加一个数字，因此保持只要用户调用该函数即可创建。简单的代码是：

 Function FileExist(FilePath As String) As Boolean

Dim TestStr As String
    On Error Resume Next
    TestStr = Dir(FilePath)
On Error GoTo 0

If TestStr = "" Then
    FileExist = False
Else
FileExist = True
End If
End Function

我有一个代码，它按步骤制作：

Sub VECTORES()
Dim filestr As String
Dim x As Long
Dim saved As Boolean
x = 2
saved = False
Dim sht As Worksheet
Dim fnd As Variant
Dim rplc As Variant
fnd = 7
rplc = "007"

Set sht = Sheets("DATOS")

' Selects a range and clear the content of this range
    Range("A2").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.ClearContents
    Range("A2").Select
'Opens a workbook and enters a loop if there is no info in a range of cells just copy the selected cell, 'and paste the info in original file. If there is more than 2 lines of info copies all lines and paste in 'original file
        Workbooks.Open Filename:="Pathfilename"
        If Cells(3, 1) = "" Then
        Range("A2").Select
        Range(Selection, Selection.End(xlToRight)).Select
        Selection.Copy
        Windows("Original file").Activate
        Selection.PasteSpecial Paste:=xlPasteValues, operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
        Range("D2").Select
        Application.CutCopyMode = False
        ActiveCell.FormulaR1C1 = "'001"
'It goes and looks for a 7 in the range of cells, if it finds it replaces it with rplc="007". Goes and 'does it with every sheet in the workbook
        Range("K2").Select
        Application.CutCopyMode = False
        Selection.TextToColumns Destination:=Range("K2"), DataType:=xlFixedWidth, _
            FieldInfo:=Array(0, 2), TrailingMinusNumbers:=True
        For Each sht In ActiveWorkbook.Worksheets
      sht.Columns("K").Replace what:=fnd, Replacement:=rplc, _
        LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, _
        SearchFormat:=False, ReplaceFormat:=False
    Next
        Range("A1").Select
        Range(Selection, Selection.End(xlToRight)).Select
        Range(Selection, Selection.End(xlDown)).Select
        Selection.Copy
        Workbooks.Add
        ActiveSheet.Paste
        Windows("Pathfilename").Activate
        ActiveWindow.Close
        Range("A2") = Format(Now, "YYYYMMDD")
        
    
    filestr = "Where the file is going to be saved"
     If FileExist(filestr & Format(Date, "DDMMMMYY") & ".xls") = False Then
        ActiveWorkbook.SaveAs (filestr & Format(Date, "DDMMMMYY") & ".xls"), _
            FileFormat:=xlExcel8, Password:="", WriteResPassword:="", _
            ReadOnlyRecommended:=False, CreateBackup:=False
        ActiveWindow.Close
    Exit Sub
    End If
    
    Do While saved = False
    If FileExist(filestr & Format(Date, "DDMMMMYY") & -x & ".xls") = False Then
     ActiveWorkbook.SaveAs (filestr & Format(Date, "DDMMMMYY") & -x & ".xls"), _
           FileFormat:=xlExcel8, Password:="", WriteResPassword:="", _
            ReadOnlyRecommended:=False, CreateBackup:=False
     ActiveWorkbook.Close
    saved = True
    Else
    x = x + 1
    End If
    Loop
    
        Else
        Range("A2").Select
        Range(Selection, Selection.End(xlToRight)).Select
        Range(Selection, Selection.End(xlDown)).Select
        Selection.Copy
        Windows("OpenFile").Activate
        Selection.PasteSpecial Paste:=xlPasteValues, operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
        Range("D2").Select
        Application.CutCopyMode = False
        ActiveCell.FormulaR1C1 = "'001"
        Selection.Copy
        Range(Selection, Selection.End(xlDown)).Select
        ActiveSheet.Paste
        Range("K2").Select
        Range(Selection, Selection.End(xlDown)).Select
        Application.CutCopyMode = False
        Selection.TextToColumns Destination:=Range("K2"), DataType:=xlFixedWidth, _
            FieldInfo:=Array(0, 2), TrailingMinusNumbers:=True
        For Each sht In ActiveWorkbook.Worksheets
        sht.Columns("K").Replace what:=fnd, Replacement:=rplc, _
        LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, _
        SearchFormat:=True, ReplaceFormat:=False
    Next
        Range("A1").Select
        Range(Selection, Selection.End(xlToRight)).Select
        Range(Selection, Selection.End(xlDown)).Select
        Selection.Copy
        Workbooks.Add
        ActiveSheet.Paste
        Windows("OriginalFile").Activate
        ActiveWindow.Close
        Range("A2") = Format(Now, "YYYYMMDD")
        Range("A2").Select
        Selection.Copy
        Range(Selection, Selection.End(xlDown)).Select
        ActiveSheet.Paste
        
    
    filestr = "Where the new file will be saved"
        ChDir "Where the new file will be saved"
        Cells.Select
        Selection.Copy
        Selection.PasteSpecial Paste:=xlPasteValues, operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
    filestr = "Where the new file will be saved"
     If FileExist(filestr & Format(Date, "DDMMMMYY") & ".xls") = False Then
        ActiveWorkbook.SaveAs (filestr & Format(Date, "DDMMMMYY") & ".xls"), _
            FileFormat:=xlExcel8, Password:="", WriteResPassword:="", _
            ReadOnlyRecommended:=False, CreateBackup:=False
        ActiveWindow.Close
    Exit Sub
    End If
    
    Do While saved = False
    If FileExist(filestr & Format(Date, "DDMMMMYY") & -x & ".xls") = False Then
     ActiveWorkbook.SaveAs (filestr & Format(Date, "DDMMMMYY") & -x & ".xls"), _
           FileFormat:=xlExcel8, Password:="", WriteResPassword:="", _
            ReadOnlyRecommended:=False, CreateBackup:=False
     ActiveWorkbook.Close
    saved = True
    Else
    x = x + 1
    End If
    Loop
        End If
    End 

Sub

我知道这不是最好的代码，但是基本上它会打开一个文件，检查是否在单元格区域中具有信息，然后将其复制并粘贴到openfile中。然后，它将格式化此openfile中的单元格，特别是它必须在K列中查找数字7的最重要部分，如果发现它将其替换为“ 007”。然后，它将另存为.xls。

该代码在10台计算机中的9台计算机上运行良好。在1中，它给了我一个错误，我一直在试图找出答案，但是找不到运气。

如您所见，有一个行代码显示For Each sht In ActiveWorkbook.Worksheets ，基本上它可以在每个工作表中运行该代码，而我在这台1台计算机上遇到的问题是，它不会在每个工作表中循环，而是保持运行同样，结果是它重复结果“ 007”的时间只要有多少张纸就可以。

如果你们中的任何人都可以运行它，看看是否遇到相同的问题，那就太好了，但是我猜测这是唯一会影响整个代码的代码。我并不是真的需要在每个工作表中执行此循环，它仅需要在活动工作表中执行此循环，但是我没有弄清楚正确的格式才能做到这一点。

如果您有一个不错的解决方案，将不胜感激，因为它可以在10台计算机上运行，​​并且可以在其中10台计算机上运行

0 个答案:

没有答案
相关问题
最新问题