如果单元格具有特定值，如何复制行并将其粘贴到新创建的Excel文件中

问题描述

我是Excel VBA的新手，我确实需要以下问题的帮助：

我需要Excel创建新工作簿并根据A列值命名它们。因此，在这种情况下，我需要使用以下数据才能擅长创建17个新工作簿：

应根据A列中给出的值来命名每个工作簿，在这种情况下，新工作簿应命名为1，2，3 ... 16，18（请注意，如果不包含数字17可能），并且如果A列中的某行具有某个特定值（在这种情况下，数字为1到18，但17除外），则每个新工作簿都应复制该主表的行。另外，它还需要复制主表的标题。因此，新创建的工作簿应如下所示：

第一个工作簿应如下所示，并命名为1.xlsx

第二个工作簿应如下所示，并命名为2.xlsx

以此类推。

我尝试使用以下无效的代码将所需的值复制到其他工作表中：

Sub asd()
Dim i As Integer
Dim y As Integer
Dim xRg As Range
Dim xCell As Range
Dim A As Long
Dim B As Long
Dim C As Long

y = 18
i = 1

For i = 1 To y
    Sheets("Master").Range("A1:C1").copy Sheets(i).Range("A1:C1")

A = Worksheets("Master").UsedRange.Rows.Count
B = Worksheets(i).UsedRange.Rows.Count
    If B = 1 Then
        If Application.WorksheetFunction.CountA(Worksheets(i).UsedRange) = 0 Then B = 0
    End If
Set xRg = Worksheets("Master").Range("A1:A" & A)
On Error Resume Next
Application.ScreenUpdating = False
For C = 1 To xRg.Count
    If CStr(xRg(C).Value) = i Then
        xRg(C).EntireRow.copy Destination:=Worksheets(i).Range("A" & B + 1)
        B = B + 1
    End If
Next
Next
Application.ScreenUpdating = True
End Sub

我可以使用以下代码基于列A上的单元格值创建新的工作表：

Sub AddSheetsFromCells()

Dim xRgx As Range,wBkx As Workbook
Set wBkx = ActiveWorkbook


On Error GoTo Quit
Set dbRange = Application.InputBox("Range: ","Select Range",_
Application.Selection.Address,Type:=8)

Application.ScreenUpdating = False
Application.displayAlerts = False

For Each xRgx In dbRange
With wBkx
.Sheets.Add After:=.Sheets(.Sheets.Count)
On Error Resume Next
ActiveSheet.Name = xRgx.Value
If Err.Number = 1004 Then
Debug.Print Chr(34) & xRgx.Value & Chr(34) & " already used as a sheet name"
.ActiveSheet.Delete
End If
On Error GoTo 0
End With
Next xRgx

Application.ScreenUpdating = True
Application.displayAlerts = True
Quit:

End Sub

但是我不能将两者结合在一起或创建新的工作簿。我完全被困住了。

非常感谢您的帮助。

解决方法

暂无找到可以解决该程序问题的有效方法，小编努力寻找整理中！

如果你已经找到好的解决方法，欢迎将解决方案带上本链接一起发送给小编。

小编邮箱:dio#foxmail.com (将#修改为@）