有條件地將單元格複製到新的工作簿

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