Sub AllocateAtty() Dim lRow As Long Dim i As Long Dim MySheet As String lRow = Range("A" & Rows.Count).End(xlUp).Row Sheet1.Select On Error Resume Next For i = 3 To lRow MySheet = Cells(i, 4).Value If Cells(i, 4) <> "" And Cells(i, 5) = "" And Cells(i, 6) = "" Then Range(Cells(i, 1), Cells(i, 6)).Copy Sheets(MySheet).Range("A" & Rows.Count).End(3)(2) End If Next i Application.CutCopyMode = False Application.ScreenUpdating = True End Sub
Sub TransferData() Dim ar As Variant Dim i As Integer Dim lr As Long t = Timer Application.ScreenUpdating = False lr = Sheet1.Range("A" & Rows.Count).End(xlUp).Row Sheet1.Range("G2:G" & lr).Formula = "=IF(AND(D2<>"""",E2="""",F2=""""),D2)" ar = Array("A", "B", "C", "D") For i = 0 To UBound(ar) 'Sheets(ar(i)).UsedRange.ClearContents Sheet1.Range("G1", Sheet1.Range("G" & Sheet1.Rows.Count).End(xlUp)).AutoFilter 1, ar(i) Sheet1.Range("A1", Sheet1.Range("F" & Sheet1.Rows.Count)).Copy Sheets(ar(i)).Range("A" & Rows.Count).End(3) Next i Sheet1.[G1].AutoFilter Sheet1.Range("G2:G" & lr).ClearContents Application.CutCopyMode = False Application.ScreenUpdating = True MsgBox "Data transfer completed!", vbExclamation, "Status" MsgBox (Timer - t) End Sub
Please note that, in my sample file, the headings are in row 1 and data starts in row 2, just in case you wish to try this code in your actual work book (remember to test it in a copy of your work book first).
Private Sub Worksheet_Change(ByVal Target As Range) Application.ScreenUpdating = False If Target.Count > 1 Then Exit Sub If Target.Value = vbNullString Then Exit Sub If Intersect(Target, Columns("D:D")) Is Nothing Then Exit Sub If Cells(Target.Row, "D") <> "" And Cells(Target.Row, "E") = "" And Cells(Target.Row, "F") = "" Then Range(Cells(Target.Row, "A"), Cells(Target.Row, "F")).Copy Sheets(Target.Value).Range("A" & Rows.Count).End(3)(2) End If Application.CutCopyMode = False Application.ScreenUpdating = True MsgBox "Done!", vbExclamation End Sub
DON'T MISS
Private Sub Workbook_Open()
Dim i, LastRow
LastRow=Sheets("Master Client Matter List").Range("A" & Rows.Count).end(xlUp).Row
Sheets("AAV').range("A3:F5000").clearContents
for i=3 to LastRow
if sheets("Master Client Matter List").cells(i,"E".value=””and cells(I, “F”.value=””then
sheets(“Master Client Matter List”).cells(I,”E”and “F”) .entirerow.copy Destination=Sheers(“AAV”).Range(“A” & Rows.Count)end(xlUp).Offset(1)
end if
next i
End Sub
The code listed is the code I am trying to use. I get runtime error "9" Subscript out of range. I don't understand this error. I my code wrong?
Thank you for your time.
haharrison2