Compile Data from Multiple Users based on Criteria

[Curben]

I have a few people all entering in data into excel, since they cannot be all in one sheet they each have their own copy. I would like to be able to extract all data where column P reads "Red" from each users spreadsheet and then delete the corresponding lines from their spreadsheet (end of day activity)

The Sheets will be named
FDEntryU1AM.xlsm
FDEntryU2AM.xlsm
FDEntryU3AM.xlsm
FDEntryU4AM.xlsm
FDEntryL1AM.xlsm
FDEntryU1PM.xlsm
FDEntryU2PM.xlsm
FDEntryU3PM.xlsm
FDEntryU4PM.xlsm
FDEntryL1PM.xlsm

I will then need to do the same in another workbook for all items Labeled Blue, but that of course will be same code with just an item replaced.
The idea is after they close up the person oversseing the data can import all at once and leave the users with fresh empty workbooks.

Any help would be appreciated

 

[Trevor G]

Welcome to the forum,

what about taking a copy of the data to another sheet to start with then you can look to clear all data from the original if I am reading this correctly.

Indicated below is a method to copy data.

<font face=Courier New><SPAN style="color:#00007F">Sub</SPAN> cpy()<br><SPAN style="color:#00007F">Dim</SPAN> LR <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN>, i <SPAN style="color:#00007F">As</SPAN> <SPAN style="color:#00007F">Long</SPAN><br><SPAN style="color:#00007F">With</SPAN> Sheets("Sheet1")<br>    LR = .Range("P" & Rows.Count).End(xlUp).Row<br>    <SPAN style="color:#00007F">For</SPAN> i = 1 <SPAN style="color:#00007F">To</SPAN> LR<br>        <SPAN style="color:#00007F">If</SPAN> .Range("P" & i).Value = "Red" <SPAN style="color:#00007F">Then</SPAN> .Rows(i).Copy Destination:=Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1)<br>    <SPAN style="color:#00007F">Next</SPAN> i<br><SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">With</SPAN><br><SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">Sub</SPAN></FONT>

 

[Curben]

Im not sure that is complicated enough

This is to batch pulling from 10 user files into 1 or 2 master files. 1

Essentially
From Master File:
Open User 1 File
Copy(CUT) all relevant date (Red or Blue)
Paste into master file.
Save the user file with the data now removed
Close the user file
Move onto the next user file and repeat (9 more times)

Theoritically I wouldn't be against a macro that will actually Open Red and Blue masters and pull the data for each so it is one operation instead of two

 

[Trevor G]

What about something like this then.

Sub Open_My_Files()
'Open all workbooks and do something
Dim MyFile As String
Dim ws As Worksheet
Dim myPath As String
myPath = "M:\Access Files\" 'Change path
MyFile = Dir(myPath)

Do While MyFile <> ""
If MyFile Like "*.xls" Then
Workbooks.Open myPath & MyFile

With Sheets("Sheet1")
LR = .Range("p" & Rows.Count).End(xlUp).Row
For i = 1 To LR
If .Range("p" & i).Value = "Red" Then .Rows(i).Copy Destination:=Workbooks.Open("M:\Access Files\tblStaff Import.xls").Sheets("Staff").Range("A" & Rows.Count).End(xlUp).Offset(1) 'Change workbook name and sheet name
Next i
End With

Next ws
ActiveWorkbook.Close True
End If
MyFile = Dir
Loop
End Sub

 

[Curben]

Compile Error:

Next without For

 

[Trevor G]

Compile Error:

Next without For

Delete

Next ws

 

[Curben]

not working

2 reasons
1. The data is in rows/columns that have been hidden by Groups. It will open and close every file in the directory however.
If i open the group then come the second issue
2. It really doesnt do anything. Once it finds matching data, it stops. no copying or pasting, doesnt even save and close the file.

 

[Curben]

Ok the code below works, But I will need to repeat it for each file I am pulling Data from the way it is (I just recorded the macro while trying to do it manually as efficient as possible.) and I am not confident enough to make the loop work for this.

Anything that can be done to loop as the Initial code i was given does (The every file in the directory method works fine) or to make all of this less convoluted. But I think this way it may show what I am doing now.

I do appreciate all the help given here.

Sub CompileData()
'
' CompileData Macro
' Retrieve items from user files into this master.
'
' Keyboard Shortcut: Ctrl+Shift+Q
'
Range("A1").End(xlDown).Offset(1, 0).Select
'
    Workbooks.Open Filename:="W:\Forms\FD User Entry Forms\FDEntryL1AM.xlsm"
    ActiveSheet.Outline.ShowLevels RowLevels:=0, ColumnLevels:=2
    ActiveSheet.Outline.ShowLevels RowLevels:=2
    Rows("1:1").Select
    Selection.AutoFilter
    ActiveSheet.Range("$1:$9").AutoFilter Field:=16, Criteria1:="REDBucket"
    Range("A2:P2").Select
    Range(Selection, Selection.End(xlDown)).Select
    ActiveSheet.Range("$1:$9").AutoFilter Field:=16, Criteria1:="REDBucket"
    Range("A2:P2").Select
    Range(Selection, Selection.End(xlDown)).Select
    Application.CutCopyMode = False
    Selection.Copy
    Windows("Copy of REDBucket Bin Master.xlsm").Activate
    Sheets("REDBucket Vendor Bin").Activate
 
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Windows("FDEntryL1AM.xlsm").Activate
    Application.CutCopyMode = False
    Selection.ClearContents
    ActiveSheet.Range("$1:$9").AutoFilter Field:=16
    Columns("A:P").Select
    ActiveWorkbook.Worksheets("Bin Entry").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Bin Entry").Sort.SortFields.Add Key:=Range( _
        "C2:C1048576"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    With ActiveWorkbook.Worksheets("Bin Entry").Sort
        .SetRange Columns("A:P")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Range("A1").Select
    ActiveSheet.Outline.ShowLevels RowLevels:=0, ColumnLevels:=1
    ActiveSheet.Outline.ShowLevels RowLevels:=1
    ActiveWorkbook.Save
    ActiveWindow.Close
End Sub

 

[Trevor G]

Look at this as loop and see if you can adapt it for your workbook names

Sub WkBkLoop()
Dim avData As Variant, myWorkbook As Workbook
Dim i As Integer

avData = Array("North", "South", "East", "West")
For i = LBound(avData) To UBound(avData)
Set myWorkbook = Workbooks.Open(FileName:=avData(i) & ".xlsm")
'Process data here you code here
myWorkbook.Close SaveChanges:=True
Next i
End Sub

 

[Curben]

Look at this as loop and see if you can adapt it for your workbook names

Ok, if i am understanding correctly,
for the array, replace the directions with the File names (excluding the extension) and make sure the extesion is correct as well?
Then input my code in between where the commented line is?

Forgive my ignorance, All the VBA I know is what i have read from code snippets and my ability to write it is limited, tho I can ussually do a good job of twisting it as needed