Question

我有一个工作簿，可以根据第一列中的值创建其他工作簿并将数据移到它们。之后我需要工作簿将刚刚复制的数据存储在与存储变量同名的工作表中（在下一个空行中），或者创建选项卡（如果它不存在）。

但是我在使用变量名称粘贴到选项卡时遇到问题，如果变量尚未作为工作表存在，则不知道如何创建新工作表。

With Worksheets(SupID).Range("A" & LastRow(SupID) + 1).Paste我遇到了麻烦。

下面的当前代码。谢谢！

Private Sub CopyItOver()

 Dim myVal As String
 Dim SupID As String

    'Store Supplier ID
  SupID = Trim(Sheets("Raw Data").Range("A2").Value)

    'Create workbook
  Set newbook = Workbooks.Add

    'Copy Records
  Set myRng = Workbooks("Book1.xlsm").Worksheets("Raw Data").Range("B2:X7")
  myRng.Copy
  newbook.Worksheets("Sheet1").Range("A2").PasteSpecial (xlPasteValues)

    'Create Header
  newbook.Worksheets("Sheet1").Range("A1").Value = "ZHF"
  newbook.Worksheets("Sheet1").Range("B1").Value = "CTO"
  newbook.Worksheets("Sheet1").Range("C1").Value = "RET"
  newbook.Worksheets("Sheet1").Range("D1").Value = SupID
  newbook.Worksheets("Sheet1").Range("E1").Value = "RET"
  newbook.Worksheets("Sheet1").Range("F1").Value = "RET"
  newbook.Worksheets("Sheet1").Range("G1").Value = "6"
  newbook.Worksheets("Sheet1").Range("H1").Value = "PROD"
    newbook.Worksheets("Sheet1").Range("J1").Value =     newbook.Worksheets("Sheet1").Range("B1").Value _
    & newbook.Worksheets("Sheet1").Range("D1").Value & "TEMPNUMBER"
  newbook.Worksheets("Sheet1").Range("I1").Value =     newbook.Worksheets("Sheet1").Range("J1").Value _
    & newbook.Worksheets("Sheet1").Range("C1").Value & ".CSV"
 newbook.Worksheets("Sheet1").Range("K1") = Format(Date, "ddmmyyyy")
 newbook.Worksheets("Sheet1").Range("L1").Value = "Unknown"
 newbook.Worksheets("Sheet1").Range("M1").Value = "1"

LastRow = newbook.Worksheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Row

    'Create Footer
  newbook.Worksheets("Sheet1").Range("A" & LastRow + 1).Value = "ZFV"
  newbook.Worksheets("Sheet1").Range("B" & LastRow + 1).Value = "BATCH" & "TEMPNUMBER"
  newbook.Worksheets("Sheet1").Range("C" & LastRow + 1).Value =     WorksheetFunction.CountIf(Sheets("Sheet1").Range("A1:A1000"), "RET")

    'Name Sheet
  myVal = newbook.Worksheets("Sheet1").Range("J1").Value & "RET"
  newbook.Worksheets("Sheet1").Name = myVal

    'Copy to relevant matching sheet
    With Worksheets(SupID).Range("A" & LastRow(SupID) + 1).Paste
    End With

    'Save Workbook
  NewBook.SaveAs Filename:=NewBook.Worksheets("Sheet1").Range("I1").Value

End Sub
Function DLastRow(sh As Worksheet)
    On Error Resume Next
    LastRow = sh.Cells.Find(What:="*", _
                        After:=sh.Range("A1"), _
                        Lookat:=xlPart, _
                        LookIn:=xlValues, _
                        SearchOrder:=xlByRows, _
                        SearchDirection:=xlPrevious, _
                        MatchCase:=False).Row
    On Error GoTo 0
End Function

Answer 1

错误正在发生，因为Worksheets(SupID).Range("A" & LastRow(SupID) + 1).Paste正试图在您的有效图书上找到该工作表，即新书。您需要Activate原始数据工作簿或将行更改为ThisWorkbook.Worksheets(SupID).Range("A" & LastRow(SupID) + 1).Paste。

但是，在VBA中使用（显式或隐式）Activate，Select或其他按键样式命令并不好。鉴于您只是复制值（而不是工作表格式），那么您可能会更好地将数据读入变量数组并对其进行操作。我已经调整了你的代码来证明这一点。

还有一些其他编码方面可能不像它们那样强大。我不会列出所有这些，但是将此代码与您的代码进行比较将有助于您了解它们。

Private Sub CopyItOver()
    Dim newBook As Workbook
    Dim supSheet As Worksheet
    Dim v As Variant
    Dim supID As String
    Dim namePrefix As String
    Dim footerCount As Integer
    Dim i As Integer

    'Store Supplier ID
    supID = Trim(ThisWorkbook.Worksheets("Raw Data").Range("A2").value)
    namePrefix = "CTO" & supID & "TEMPNUMBER"

    'Create workbook
    Set newBook = Workbooks.Add

    'Copy Records
    v = rawDataSheet.Range("B2:X7").value
    For i = 1 To UBound(v, 1)
        If v(i, 1) = "RET" Then footerCount = footerCount + 1
    Next

    'Write new sheet
    With newBook.Worksheets(1)
        'Values
        .Range("A2").Resize(UBound(v, 1), UBound(v, 2)).value = v
        'Header
        .Range("A1").Resize(, 13) = Array( _
            "ZHF", "CTO", "RET", supID, "RET", "RET", "6", "PROD", _
            namePrefix & "RET.CSV", namePrefix, _
            Format(Date, "ddmmyyyy"), "Unknown", "1")
        'Footer
        .Cells(.Rows.Count, "A").End(xlUp).Offset(1).Resize(, 3).value = Array( _
            "ZFV", "BATCH TEMPNUMBER", footerCount)
        'Name
        .Name = namePrefix & "RET"
        'Save
        .SaveAs Filename:=namePrefix & "RET.CSV"
    End With

    'Copy to relevant matching sheet
    On Error Resume Next
    Set supSheet = ThisWorkbook.Worksheets(supID)
    On Error Goto 0
    If newSheet Is Nothing Then
        With ThisWorkbook.Worksheets
            Set supSheet = .Add(After:=.Item(.Count))
        End With
        supSheet.Name = supID
    End If

    With supSheet
        .Cells(.Rows.Count, "A").End(xlUp).Offset(1).Resize(UBound(v, 1), UBound(v, 2)).value = v
    End With

End Sub

Answer 2

一些不太正确的事情：

在模块顶部添加Option Explicit并声明您的变量。
LastRow将是Long数据类型，但您尝试将其用作With Worksheets(SupID).Range("A" & LastRow(SupID) + 1).Paste中的数组。只需使用LastRow+1。
With Worksheets(SupID).Range("A" & LastRow(SupID) + 1).Paste End With可能应为Worksheets(SupID).Range("A" & LastRow + 1).Paste，但会粘贴myRng - 看不到您复制的任何内容。
在代码的开头，您引用Workbooks("Book1.xlsm")。如果这是代码所在的工作簿，我会将其更改为ThisWorkbook。
SupID查看当时处于活动状态的工作簿的原始数据（初始化该变量时不指定工作簿）。

如果存在命名工作表，则此函数将返回TRUE / FALSE：

Public Function WorkSheetExists(SheetName As String) As Boolean
    Dim wrkSht As Worksheet
    On Error Resume Next
        Set wrkSht = ThisWorkbook.Worksheets(SheetName)
        WorkSheetExists = (Err.Number = 0)
        Set wrkSht = Nothing
    On Error GoTo 0
End Function

希望指出正确的方向：）

修改刚注意到......

而不是写：

newbook.Worksheets("Sheet1").Range("A1").Value = "ZHF" newbook.Worksheets("Sheet1").Range("B1").Value = "CTO" newbook.Worksheets("Sheet1").Range("C1").Value = "RET" newbook.Worksheets("Sheet1").Range("D1").Value = SupID newbook.Worksheets("Sheet1").Range("E1").Value = "RET" newbook.Worksheets("Sheet1").Range("F1").Value = "RET" newbook.Worksheets("Sheet1").Range("G1").Value = "6" newbook.Worksheets("Sheet1").Range("H1").Value = "PROD"

你可以使用：

newbook.Worksheets("Sheet1").Range("A1:H1") = Array("ZHF", "CTO", "RET", "SupID", "RET", "RET", "6", "Prod")

Answer 3

我设法使用来自Here的帮助解决了我的问题，我在其中修改了以下代码并在一个单独的模块中运行，该模块允许使用之前未指定的工作表名称，后来从细胞价值。如果工作表不存在，则创建该工作表，使其与存储的值和粘贴到其中的数据的名称相匹配。感谢您的支持！

Sub TEST()

    Dim i As Integer, blnFound As Boolean
    blnFound = False

    SupID = Trim(Sheets("Raw Data").Range("A2").Value)
    Set myRng = Workbooks("Book1.xlsm").Worksheets("Raw Data").Range("B2:X7")

    myRng.Copy

    With ThisWorkbook
        For i = 1 To .Sheets.Count
            If .Sheets(i).Name = SupID Then
            blnFound = True
            .Sheets(i).Activate
            ActiveSheet.Paste Destination:=Range("A" & LastRow + 1)
            Exit For
            End If
        Next i

        If blnFound = False Then
        .Sheets.Add
        With ActiveSheet
            .Name = SupID

            ActiveSheet.Paste Destination:=Range("A" & LastRow + 1)
        End With
        End If
    End With

End Sub

使用存储的值来调用或创建＆amp;电话表

3 个答案: