Question

我暂时没有使用过VBA，这就是我要做的事情：我有一个带有一列ID号的工作表，然后是一堆列，它们引用了具有该ID的人做了什么（“1”）或不做（“0”）。像这样：

ID     Task1     Task2     Task3
103    1         1         0
129    0         1         0
154    1         1         1
189    1         0         1
204    0         1         1

我希望宏做的是为每个任务创建一个新的工作簿（并以该任务的名义保存工作簿），然后仅使用已完成任务的人员的ID＃填充每个工作簿。因此，它应该创建并保存名为“Task1”的工作簿，其在A列中具有值103,154和189，创建并保存名为“Task2”的单独工作簿，其值为103,129,154和204在A栏中，依此类推。

到目前为止，我还没有取得过成功。我想出了这个：

Sub CopyToWorkbooks()
Dim lRow, lCol As Integer

Sheets("Sheet1").Select
lRow = Range("A" & Rows.Count).End(xlUp).Row
lCol = Cells(1, Columns.Count).End(xlToLeft).Column

For Each cell In Range(Cells(1, "B"), Cells(1, lCol))
    Union(Range("A1:A" & lRow), Range(Cells(1, cell.Column), Cells(lRow, cell.Column))).Copy
    Workbooks.Add
    Range("A1").PasteSpecial
    ActiveWorkbook.SaveAs Filename:= _
    "Users:User:Desktop:WorkbookFolder:" & cell.Value & ".xls" 'For saving the workbook on a Mac
    ActiveWorkbook.Close
Next cell

Application.CutCopyMode = False
End Sub

这样可以使用正确的工作簿名称成功创建并保存3个单独的工作簿，但它会复制A列中的所有值以及与新工作簿名称对应的列中的所有值。因此，例如，工作簿“Task2”如下所示：

ID     Task2
103    1
129    1
154    1
189    0
204    1

非常感谢任何帮助。谢谢！

Answer 1

为了完成您描述的任务，我对您的代码进行了一些更改：

Sub CopyToWorkbooks()
    Dim lRow As Integer
    Dim lCol As Integer
    Dim i As Integer
    Dim j As Integer
    Dim tCount As Integer
    Dim ws As Worksheet
    Dim TaskArr As Variant

    Application.ScreenUpdating = False
    Set ws = ActiveWorkbook.Sheets("Sheet1")
    ws.Select

    lRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
    lCol = ws.Cells(1, Columns.Count).End(xlToLeft).Column

    'Loops through each column
    For i = 2 To lCol Step 1
        ReDim TaskArr(1 To 2, 1 To 1)
        tCount = 1
        TaskArr(1, tCount) = ws.Cells(1, 1).Value
        TaskArr(2, tCount) = ws.Cells(1, i).Value
        'Loops through each row
        For j = 2 To lRow Step 1
            If ws.Cells(j, i).Value = 1 Then
                tCount = tCount + 1
                'Read values to array
                ReDim Preserve TaskArr(1 To 2, 1 To tCount)
                TaskArr(1, tCount) = ws.Cells(j, 1).Value
                TaskArr(2, tCount) = ws.Cells(j, i).Value
            End If
        Next j

        'Add new workbook
        Workbooks.Add
        ActiveSheet.Range("A1", ActiveSheet.Cells(tCount, 2).Address) = WorksheetFunction.Transpose(TaskArr)
        ActiveWorkbook.SaveAs Filename:="Users:User:Desktop:WorkbookFolder:" & ws.Cells(1, i).Value & ".xls"     'For saving the workbook on a Mac
        ActiveWorkbook.Close
        Erase TaskArr
    Next i

    Application.ScreenUpdating = True
End Sub

我没有复制/粘贴值，而是将每个任务的值读入数组并将其插入到目标工作簿的工作表中。

Answer 2

'以下是您发布的程序，'''''''''''''''''''''''''''

Sub CopyToWorkbooks()
Dim lRow, lCol As Integer

Sheets("Sheet1").Select
lRow = Range("A" & Rows.Count).End(xlUp).Row
lCol = Cells(1, Columns.Count).End(xlToLeft).Column

For Each cell In Range(Cells(1, "B"), Cells(1, lCol))
    Union(Range("A1:A" & lRow), Range(Cells(1, cell.Column), Cells(lRow, cell.Column))).Copy
    Workbooks.Add
    Range("A1").PasteSpecial
    ActiveWorkbook.SaveAs Filename:= _
    "Users:User:Desktop:WorkbookFolder:" & cell.Value & ".xls" 'For saving the workbook on a Mac
    ''''''''''''''''''''''''
    'ActiveWorkbook.Sheets(1).Activate
    Call FilterSub
    ActiveWorkbook.Save
    ''''''''''''''''''''''''''
    ActiveWorkbook.Close
Next cell

Application.CutCopyMode = False
End Sub

'以下是根据您的要求过滤新创建的工作簿的过程：

Sub FilterSub()
Dim rowNo
Dim cellMatch
Dim pathh
pathh = ActiveWorkbook.Name
With Application.Workbooks(pathh)
rowNo = Range("A" & Rows.Count).End(xlUp).Row
Set cellMatch = Range("B:B").Find(what:=0)
Do While Not cellMatch Is Nothing
'If cellMatch.Address = "$B$1" Then
'Exit Do
'End If
cellMatch.EntireRow.Delete
Set cellMatch = Range("B:B").FindNext
Loop

Set cellMatch = Nothing
End With
End Sub

有条件地将单元格复制到新工作簿

2 个答案: