循环浏览工作簿以创建新工作簿，并将其与单元格值一起保存为标题，否则复制/粘贴到现有工作簿

Question

我有一个Excel工作簿，上面有日期和姓名列表。工作簿有500行。日期在A列，名称在B列。工作簿中所有500行的日期都相同，每个名称都是唯一的。

我的目标是最终得到一些工作簿，并根据它们的名称保存在一个单独的目录中。每个工作簿都有相同的标题（A列：日期，B列：名称），行按照A列中的日期排列。

我有其他行数不同但列数相同的工作簿。

>

如果单元格B2中不存在具有值的文件，请复制行，在单元格B2中创建一个名称为值且标题位于行1的文件，粘贴行并另存为新工作表的单元格B2中的值名称。

如果在Cell B2中具有值的文件（例如David）已经存在，则复制整行，打开该文件，将行（包含日期）粘贴到第一个可用的空白行。（我曾想根据日期值插入行，但无法这样做，并将根据标头对数据进行排序）

工作簿新工作簿的创建、复制、粘贴命名和工作正常。

我遇到的问题是该过程似乎忽略了第一个IF语句，导致excel给出问题：“名称为David的文件存在于此位置，您想覆盖它吗？”

以下是我迄今为止所做的工作，如果我不清楚，请告诉我，真诚感谢您的帮助：

Option Explicit  
Sub CreateNewWorkBook()  
    Dim ThisPath As String  
    Dim ActivePath As String  
    Dim rRange As Range  
    Dim rCell As Range  
    Application.ScreenUpdating = False  
    ThisPath = ThisWorkbook.Path  
    ActivePath = ActiveWorkbook.Path  
    Set File1 = ThisWorkbook  
    Set File2 = ActiveWorkbook  
    Set rRange = Range("B2", Range("B655365").End(xlUp))  
    Set rCell = cell.Value  
For Each rCell In rRange.Cells  
    If Dir(ThisPath & "\" & "Names" & "\" & rCell) = "" Then  
    rCell.EntireRow.Copy  
    Workbooks.Add  
    Range("2:2").PasteSpecial xlPasteAll  
    ActiveWorkbook.SaveAs Filename:=ThisPath & "\" & "Names" & "\" & Range("B2").Value  
    Range("A1").Value = "Date"  
    Range("B1").Value = "Name"  
    ActiveWorkbook.Close SaveChanges:=True  
Else: rCell.EntireRow.Copy  
    Workbooks.Open Filename:=(ThisPath & "\" & "Names" & " \ " & "rCell")  
    UsedRange.Columns(1).Offset(1, 0).PasteSpecial xlPasteValues  
    ActiveWorkbook.Close SaveChanges:=True  
    End If  
    Next rCell  
    Exit For  
    End Sub  

Answer 1

问题似乎是您的IF语句正在查找文件夹，而不是文件。除非您的名称列包含文件扩展名，否则您还没有为您的IF语句提供足够的信息来检查文件。

您输入If语句的路径如下所示：

"C:\Users\Workbook Folder\Names\Joe Smith"

由于没有文件扩展名，IF语句认为“Joe Smith”是一个文件夹。

要解决此问题，可以向代码中添加文件扩展名，如下所示：

If Dir(ThisPath & "\" & "Names" & "\" & rCell & ".xls*") = "" Then

请注意，使用通配符检查以“.xls”开头的所有文件扩展名。