Условно скопировать ячейки в новую рабочую книгу

Question

Я не работал с VBA некоторое время, и вот что я пытаюсь сделать: у меня есть рабочий стол с столбцом идентификационных номеров, а затем куча столбцов, которые ссылаются на ли человек с этим удостоверением личности сделал что-то («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», которая имеет значения 103, 154 и 189 в столбце A, создать и сохранить отдельную книгу под названием «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 отдельные книги с правильными именами рабочих книг, но он копирует все значения в столбце А и все из значений в столбце, что соответствует с новым книга имя. Так, например, рабочая тетрадь «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