用于使用原始文件中的数据更新主工作簿的VBA代码

时间:2012-07-29 09:10:37

标签: excel-vba vba excel

我正在尝试使用能够从原始文件复制数据并在主工作簿中为原始文件的A列中的每个值更新单个工作表的代码。

背景:原始文件的A列中提到了许多唯一ID,其他列包含每个唯一ID的相应数据。每个唯一ID在主工作簿中都有一个单独的工作表。

要求:

  1. 删除原始文件中要删除的工作表中提到的不需要的唯一ID
  2. 从原始文件复制整行,在主工作簿中找到相关的唯一ID表,然后将数据粘贴到最后一行。
  3. 如果主工作簿中没有唯一的ID表,则创建它并粘贴数据。
  4. 问题:

    1. 我所拥有的代码一直停留在主页中找到正确的工作表,它无法找到工作表,当它创建一个带有名称的新工作表时,它会给出工作表名称已存在的错误。 / LI>
    2. 如果需要为唯一ID创建新工作表,则应继续循环并粘贴其他ID的数据。
    3. 最后应该给出一个消息框,提供所有已创建的新工作表的详细信息。
    4. 请帮帮我......我一直试图解决这个问题。

      原始文件(Excel): Columns in the raw file excel

      主文件(Excel): Columns in the master file

      主文件中的工作表名称: Sheet Names in Master File

      代码:

          Sub unique_ids()
          Dim NewFN As String, MasterFN As String
          Dim lrow As Long, i As Long, drow As Long, j as Long
          Dim rngf As Range, rngv As Range
          Dim SName As Variant
          Dim FoundDup As Range
      
          'Open the Master file
          proceed:
          MasterFN = Application.GetOpenFilename(FileFilter:="All files (*.*), *.*",       Title:="Please open the Master File")
          If MasterFN = "" Then
          MsgBox "You have not selected a file."
          GoTo proceed
          Else
          Workbooks.Open Filename:=MasterFN
          End If
          MasterFN = ActiveWorkbook.Name
      
          'Open the raw file
          proceed1:
          NewFN = Application.GetOpenFilename(FileFilter:="All files (*.*), *.*", Title:="Please open the raw File")
          If NewFN = "" Then
          MsgBox "You have not selected a file."
          GoTo proceed1
          Else
          Workbooks.Open Filename:=NewFN
          End If
      
          'Save backup file
          ActiveWorkbook.SaveAs Filename:="D:\Counts-" & Format(Date, "dd-mmm-yy") & ".xlsx", FileFormat:= _
          xlOpenXMLWorkbook, CreateBackup:=False
          Workbooks("Counts-" & Format(Date, "dd-mmm-yy") & ".xlsx").Close
          Workbooks.Open Filename:=NewFN
          NewFN = ActiveWorkbook.Name
      
          'Delete the "to be removed" IDs
          Sheets("counts").Select  
          For Row = Range("A65536").End(xlUp).Row To 2 Step -1 
      
          Set FoundDup = Sheets("To be deleted").Range("A:A").Find(Cells(Row, 1), LookIn:=xlValues, lookat:=xlWhole) 
      
          If Not FoundDup Is Nothing Then 
              Cells(Row, 1).EntireRow.Delete 
          End If 
      
          Next Row
      
          ‘Update Data
      
          For j = 2 To lrow
          SName = Workbooks(NewFN).Worksheets("counts").Range("K" & j).Value
          On Error GoTo new_tab
          Workbooks(NewFN).Worksheets("Counts").Range("A" & j & ":I" & j).Copy     Workbooks(MasterFN).Worksheets(SName).Range("B" & Rows.Count).End(xlUp).Offset(1, 0)
          Workbooks(MasterFN).Worksheets(SName).Range("A" & Rows.Count).End(xlUp).Value = Format(Date, "dd-mmm-yy")
          drow = Workbooks(MasterFN).Worksheets(SName).Range("K" & Rows.Count).End(xlUp).Offset(-1, 0).Row
          Workbooks(MasterFN).Worksheets(SName).Range("K" & drow - 1 & ":S" & drow - 1).Copy Workbooks(MasterFN).Worksheets(SName).Range("K" & drow & ":S" & drow)
          Next j
      
          new_tab:
          MsgBox "New ID encountered", vbCritical
         Workbooks(MasterFN).Sheets.Add(after:=Workbooks(MasterFN).Sheets(Worksheets.Count)).Name = SName
          Workbooks(NewFN).Worksheets("counts").Range("A" & j & ":I" & j).Copy       Workbooks(MasterFN).Worksheets(SName).Range("B" & Rows.Count).End(xlUp)
          Workbooks(MasterFN).Worksheets(SName).Range("A" & Rows.Count).End(xlUp).Value = Format(Date, "dd-mmm-yy")
          drow = Workbooks(MasterFN).Worksheets(SName).Range("K" & Rows.Count).End(xlUp)
          Workbooks(MasterFN).Worksheets(SName).Range("K" & drow - 1 & ":S" & drow - 1).Copy  Workbooks(MasterFN).Worksheets(SName).Range("K" & drow & ":S" & drow)
      
          MsgBox "This work is now complete, new sheet added - " & SName
      
          End Sub        
      

1 个答案:

答案 0 :(得分:0)

我在这里看到的第一个潜在问题是在For j = 2 To lrow循环中你一直指的是变量i而不是我认为应该是j的变量。我看不到i变量已经在任何地方初始化了?