Option Explicit Sub TransferData() Dim ar As Variant, i As Integer ar = [{"Study A","Study B","Study C";"Person A","Person B", "Person C"}] Application.ScreenUpdating = False For i = 1 To UBound(ar, 2) Sheets(ar(1, i)).UsedRange.Offset(1).ClearContents With Sheet1 .AutoFilterMode = False With Range("A1", Range("A" & Rows.Count).End(xlUp)) .AutoFilter 1, ar(2, i) .EntireRow.Copy Sheets(ar(1, i)).Range("A" & Rows.Count).End(xlUp).PasteSpecial xlPasteValues ActiveSheet.AutoFilterMode = False Sheets(ar(1, i)).Columns.AutoFit End With End With Next i Application.CutCopyMode = False Application.ScreenUpdating = True MsgBox "Data transfer completed!", vbExclamation, "STATUS" End Sub
Option Explicit Sub CreateSheetsTransferData() Dim ar As Variant Dim i As Integer Dim lr As Long Dim ws As Worksheet Dim sh As Worksheet Application.ScreenUpdating = False lr = Range("A" & Rows.Count).End(xlUp).Row ar = Sheet1.Range("A2", Sheet1.Range("A" & Sheet1.Rows.Count).End(xlUp)) Set sh = Sheet1 For i = LBound(ar) To UBound(ar) If Not Evaluate("ISREF('" & ar(i, 1) & "'!A1)") Then Worksheets.Add(After:=Sheets(Sheets.Count)).Name = ar(i, 1) End If Set ws = Worksheets(CStr(ar(i, 1))) sh.Range("A1:A" & lr).AutoFilter 1, ar(i, 1) sh.[A1].CurrentRegion.Copy ws.[A1] ws.Columns.AutoFit Next i sh.[A2].AutoFilter Application.CutCopyMode = False Application.ScreenUpdating = True sh.Select MsgBox "Sheets created/data transfer completed!", vbExclamation, "STATUS" End Sub
Sub TransferData() Dim lr As Long Dim i As Integer Dim ws As Worksheet lr = Range("A" & Rows.Count).End(xlUp).Row Application.ScreenUpdating = False For Each ws In Worksheets If ws.Name <> "Main sheet" Then ws.UsedRange.Offset(1).ClearContents Next ws For i = 2 To lr If Cells(i, 8).Value = "Yes" Then Range(Cells(i, 1), Cells(i, 6)).Copy Sheet2.Range("A" & Rows.Count).End(3)(2) End If If Cells(i, 9).Value = "Yes" Then Range(Cells(i, 1), Cells(i, 6)).Copy Sheet3.Range("A" & Rows.Count).End(3)(2) End If If Cells(i, 10).Value = "Yes" Then Range(Cells(i, 1), Cells(i, 6)).Copy Sheet4.Range("A" & Rows.Count).End(3)(2) End If Next Application.CutCopyMode = False Application.ScreenUpdating = True End Sub
Sub TransferData() Dim ws As Worksheet Application.ScreenUpdating = False For Each ws In Worksheets If ws.Name <> "Main sheet" Then ws.UsedRange.Offset(1).ClearContents Next ws Sheet1.Range("H1", Sheet1.Range("H" & Sheet1.Rows.Count).End(xlUp)).AutoFilter 1, "Yes", 7 Sheet1.Range("A2", Sheet1.Range("F" & Sheet1.Rows.Count).End(xlUp)).Copy Sheet2.Range("A" & Rows.Count).End(3)(2) [H1].AutoFilter Sheet1.Range("I1", Sheet1.Range("I" & Sheet1.Rows.Count).End(xlUp)).AutoFilter 1, "Yes", 7 Sheet1.Range("A2", Sheet1.Range("F" & Sheet1.Rows.Count).End(xlUp)).Copy Sheet3.Range("A" & Rows.Count).End(3)(2) [I1].AutoFilter Sheet1.Range("J1", Sheet1.Range("J" & Sheet1.Rows.Count).End(xlUp)).AutoFilter 1, "Yes", 7 Sheet1.Range("A2", Sheet1.Range("F" & Sheet1.Rows.Count).End(xlUp)).Copy Sheet4.Range("A" & Rows.Count).End(3)(2) [J1].AutoFilter Application.CutCopyMode = False Application.ScreenUpdating = True End Sub
Sheet1.Range("K1", Sheet1.Range("K" & Sheet1.Rows.Count).End(xlUp)).AutoFilter 1, "Yes", 7 Sheet1.Range("A2", Sheet1.Range("F" & Sheet1.Rows.Count).End(xlUp)).Copy Sheet4.Range("A" & Rows.Count).End(3)(2) [K1].AutoFilter
Sheet1.Range("A2", Sheet1.Range("F" & Sheet1.Rows.Count).End(xlUp)).Copy Sheet4.Range("A" & Rows.Count).End(3)(2)
Sub TransferData() Dim ws As Worksheet Application.ScreenUpdating = False For Each ws In Worksheets If ws.Name <> "Main sheet" Then ws.UsedRange.Offset(1).ClearContents Next ws Sheet1.Range("I1", Sheet1.Range("I" & Sheet1.Rows.Count).End(xlUp)).AutoFilter 1, "Yes", 7 Sheet1.Range("A2", Sheet1.Range("G" & Sheet1.Rows.Count).End(xlUp)).Copy Sheet2.Range("A" & Rows.Count).End(3)(2) [I1].AutoFilter Sheet1.Range("J1", Sheet1.Range("J" & Sheet1.Rows.Count).End(xlUp)).AutoFilter 1, "Yes", 7 Sheet1.Range("A2", Sheet1.Range("G" & Sheet1.Rows.Count).End(xlUp)).Copy Sheet3.Range("A" & Rows.Count).End(3)(2) [J1].AutoFilter Sheet1.Range("K1", Sheet1.Range("K" & Sheet1.Rows.Count).End(xlUp)).AutoFilter 1, "Yes", 7 Sheet1.Range("A2", Sheet1.Range("G" & Sheet1.Rows.Count).End(xlUp)).Copy Sheet4.Range("A" & Rows.Count).End(3)(2) [K1].AutoFilter Application.CutCopyMode = False Application.ScreenUpdating = True End Sub
Option Explicit Sub TransferData() Dim ws As Worksheet Dim lr As Long Application.ScreenUpdating = False For Each ws In Worksheets If ws.Name <> "Main sheet" Then ws.UsedRange.Offset(1).ClearContents Next ws Sheet1.Range("I1", Sheet1.Range("I" & Sheet1.Rows.Count).End(xlUp)).AutoFilter 1, "Yes", 7 lr = Sheet1.Range("A" & Rows.Count).End(xlUp).Row Sheet1.Range("A2:G" & lr).Copy Sheet2.Range("A" & Rows.Count).End(3)(2) [I1].AutoFilter Sheet1.Range("J1", Sheet1.Range("J" & Sheet1.Rows.Count).End(xlUp)).AutoFilter 1, "Yes", 7 lr = Sheet1.Range("A" & Rows.Count).End(xlUp).Row Sheet1.Range("A2:G" & lr).Copy Sheet3.Range("A" & Rows.Count).End(3)(2) [J1].AutoFilter Sheet1.Range("K1", Sheet1.Range("K" & Sheet1.Rows.Count).End(xlUp)).AutoFilter 1, "Yes", 7 lr = Sheet1.Range("A" & Rows.Count).End(xlUp).Row Sheet1.Range("A2:G" & lr).Copy Sheet4.Range("A" & Rows.Count).End(3)(2) [K1].AutoFilter Sheet1.Range("L1", Sheet1.Range("L" & Sheet1.Rows.Count).End(xlUp)).AutoFilter 1, "Yes", 7 lr = Sheet1.Range("A" & Rows.Count).End(xlUp).Row Sheet1.Range("A2:G" & lr).Copy Sheet5.Range("A" & Rows.Count).End(3)(2) [L1].AutoFilter MsgBox "Data transfer completed!", vbExclamation Application.CutCopyMode = False Application.ScreenUpdating = True End Sub
DON'T MISS