在两个不同的工作簿中创建工作表并在 ThisWorkbook 中的列表之后命名它们

Question

我有一个文件，其中名称列在 A 列中，信息在其他列中。使用IF 函数，我决定需要使用哪个工作簿，然后将工作表添加到包含A 列中名称的特定工作簿中。代码工作正常，直到第7 行停止工作，我不知道为什么。我得到了Run-time error 1004。一次，它运行良好，然后我再次对其进行测试，它完全崩溃了。你能帮我解决这个问题吗？

    Dim Ki As range
    Dim ListSh As range
    Dim x As Integer
    Dim lr As Integer
    Dim wbkRAM As Workbook
    Dim wbkPSS As Workbook

    Set wbkRAM = Workbooks.Open(Filename:="C:\Users\212478002\Desktop\VCP\PSS\RAM.xlsx")
    Set wbkPSS = Workbooks.Open(Filename:="C:\Users\212478002\Desktop\VCP\PSS\PSS.xlsx")

    lr = Cells(Rows.Count, 1).End(xlUp).Row

            With ThisWorkbook.Sheets("Sheet1")

                 Set ListSh = .range("A2:A" & .Cells(.Rows.Count, "A").End(xlUp).Row)

            End With

    For x = 1 To lr

        For Each Ki In ListSh

          x = x + 1

                If ThisWorkbook.Sheets("Sheet1").Cells(x, "B") = "PSS" Then

                        wbkPSS.Sheets.Add(After:=Sheets(Sheets.Count)).Name = Ki.Value
                        ThisWorkbook.Sheets("Sheet1").Cells(x, "D").Copy
                        wbkPSS.Sheets(Ki.Value).Cells(1, "A").PasteSpecial

                Else
                        wbkRAM.Sheets.Add(After:=Sheets(Sheets.Count)).Name = Ki.Value
                        ThisWorkbook.Sheets("Sheet1").Cells(x, "C").Copy
                        wbkRAM.Sheets(Ki.Value).Cells(1, "A").PasteSpecial
                End If
        Next
    Next
End Sub

Answer 1

试试这个，如果你遇到错误，点击调试，让我知道是哪一行导致了错误..

Dim x As Integer
Dim lr As Integer
Dim wbkRAM As Workbook
Dim wbkPSS As Workbook
Dim ws As Worksheet
Sub dunnothename()
    Set ws = ThisWorkbook.Sheets("Sheet1")
    Set wbkRAM = Workbooks.Open(Filename:="C:\Users\212478002\Desktop\VCP\PSS\RAM.xlsx")
    Set wbkPSS = Workbooks.Open(Filename:="C:\Users\212478002\Desktop\VCP\PSS\PSS.xlsx")
    lr = ws.Cells(Rows.Count, 1).End(xlUp).Row
    Set ListSh = ws.Range("A2:A" & lr)
    For x = 1 To lr
        If ws.Cells(x, 2) = "PSS" Then
                wbkPSS.Sheets.Add(After:=wbkPSS.Sheets(wbkPSS.Sheets.Count)).Name = ws.Cells(x, 1).Value
                ws.Cells(x, 4).Copy wbkPSS.Sheets(ws.Cells(x, 1).Value).Cells(1, 1)
        Else
                wbkRAM.Sheets.Add(After:=wbkRAM.Sheets(wbkRAM.Sheets.Count)).Name = ws.Cells(x, 1).Value
                ws.Cells(x, 3).Copy wbkRAM.Sheets(ws.Cells(x, 1).Value).Cells(1, 1)
        End If
    Next
End Sub