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

问题描述：

我还没有用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”看起来像这样：

任何帮助将不胜感激。谢谢！

答

我已经以达到你所描述的任务做了一些改动你的代码：

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

而是复制/粘贴的价值观，我看每个任务的值到一个数组，将其插入到目标工作簿的工作表中。

谢谢，这个作品完美！我测试了Søren和ZAT提供的答案，两者都完成了这项工作，但这种方法运行得更快。 – abclist19 2014-10-05 17:54:00

答

“下面是您发布的过程中，‘’”“”“”由我““”“”“”“”“”

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

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

相关推荐