将工作表创建到两个不同的工作簿中，并以 ThisWorkbook 中的列表命名它们

Question

我有一个文件，其中名称列在 A 列中，信息列在其他列中。使用 IF 函数，我决定我需要使用哪个工作簿，然后我将 sheet 添加到包含 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:\Users2478002\Desktop\VCP\PSS\RAM.xlsx")
    Set wbkPSS = Workbooks.Open(Filename:="C:\Users2478002\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:\Users2478002\Desktop\VCP\PSS\RAM.xlsx")
    Set wbkPSS = Workbooks.Open(Filename:="C:\Users2478002\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

将工作表创建到两个不同的工作簿中，并以 ThisWorkbook 中的列表命名它们

Creating sheets into two different workbooks and naming them after the list in ThisWorkbook

excel

vba

runtime-error

add