循环工作簿以创建新工作簿并将单元格值保存为标题否则复制/粘贴到现有工作簿答案

【问题标题】：Loop through Workbook to Create New Workbooks and Save them With Cell Value as Title Else Copy/Paste to Existing Workbook循环工作簿以创建新工作簿并将单元格值保存为标题否则复制/粘贴到现有工作簿
【发布时间】：2014-05-02 14:49:22
【问题描述】：

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

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

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

通读 B 列，检查是否存在具有单元格 B2 值的文件。
如果在单元格 B2 中具有值的文件不存在，请复制行，在单元格 B2 中创建一个名称为值的文件，在第 1 行中具有标题，粘贴行并在新工作表的单元格 B2 中另存为值的名称.
如果单元格 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

【问题讨论】：

标签： vba excel

【解决方案1】：

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

您提供If 语句的路径如下所示：

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

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

要解决此问题，您可以像这样在代码中添加文件扩展名：

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

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

【讨论】：