transfer of information from identical excel files and identical sheets of accumulati

[k0st4din]

Hello, everyone,
I asked for help on this site, but several days no one can help me.
Therefore, please if you could one of you help me with a macro.
Here's the question:
I have a basic file that accrue monthly certain information. Every colleague sends me his file that has a complete copy of my, but bearing the new information that is colored red.
The main file and who receive contain 18 sheets with just specific names (ie identical names on the sheets).
Looking option will open the main file there is the macro to begin checking each sheet (I want to write the names of the sheets in the macro: eg sheets with names "tomatoes", "cucumber", "apples" and so on. n) of the resulting file and the first free line in the relevant sheet to transfer the information in my basic file (to have accumulation of information)
Filtering the red color is carried out in column "B", then copy the entire line (rows) and should be "paste special value", in my main file. If one of the sheets no red text, continue with the next sheet.
Basic File
Received file
Final results
Thank you in advance for your assistance.
I wish you good health.

[k0st4din]

Friends,
Does anyone have any idea if he could make such a macro, many looking on the web, but there are just like macros, but not exactly what I'm looking for.
Is there something you do not understand to explain in detail?

[Paul_Hossler]

Could you attach your files directly?


[Go Advanced] at lower right, and use the paperclip icon to select and upload the files to VBAEpress and not SendSpace.com

[k0st4din]

Thank you in advance for your assistance.

[k0st4din]

I think it should be something, but I do not know how to assemble and do the whole macro. Ask for some assistance from you.

Sub 
Macro1()
'Macro1 Macro
'


'
    Sheets("test").Select
    Windows("recived file.xlsm").Activate
    Sheets("test").Select
    ActiveSheet.Range("$A$1:$S$29").AutoFilter Field:=2, Criteria1:=RGB(255, 0 _
        , 0), Operator:=xlFilterFontColor
    Rows("20:29").Select
    Selection.Copy
    Windows("basic file.xlsm").Activate
    Range("A30").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Windows("recived file.xlsm").Activate
    ActiveSheet.Range("$A$1:$S$29").AutoFilter Field:=2
    Application.CutCopyMode = False
    Sheets("test2").Select
    ActiveSheet.Range("$A$1:$S$29").AutoFilter Field:=2, Criteria1:=RGB(255, 0 _
        , 0), Operator:=xlFilterFontColor
    Rows("20:29").Select
    Selection.Copy
    Windows("basic file.xlsm").Activate
    Sheets("test2").Select
    Range("A30").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Windows("recived file.xlsm").Activate
    Application.CutCopyMode = False
    ActiveSheet.Range("$A$1:$S$29").AutoFilter Field:=2
    Sheets("test3").Select
    ActiveSheet.Range("$A$1:$S$29").AutoFilter Field:=2, Criteria1:=RGB(255, 0 _
        , 0), Operator:=xlFilterFontColor
    Rows("20:29").Select
    Selection.Copy
    Windows("basic file.xlsm").Activate
    Sheets("test3").Select
    Range("A30").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Windows("recived file.xlsm").Activate
    Application.CutCopyMode = False
    ActiveSheet.Range("$A$1:$S$29").AutoFilter Field:=2
    ActiveWindow.Close
    Range("A39").Select
    Sheets("test").Select
                                 'to the end to all sheets
    ActiveWorkbook.Save 
End Sub

[k0st4din]

hello, the example of tomatoes, peaches, etc. - with him I mean, himself a macro if I can mention which sheets to check. As for examples, I've attached a three files - my principal, who receive and the third is the end result. If you want more details, please ask me to try to explain in detail. Pre thank you warmly.

[mancubus]

goes to a standard module that contains the consolidated data.

i assume the files which will be consolidated in the main workbook are in a subfolder.

Sub vbax_58805_cons_sheets()

    Dim fPath As String
    Dim fFiles, ConsSheet
    Dim i As Long, j As Long, calc As Long
    
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
        .EnableEvents = False
        .AskToUpdateLinks = False
        calc = .Calculation
        .Calculation = xlCalculationManual
    End With
    
    fPath = ThisWorkbook.Path & "\FolderNameWhichContainsRecievedFiles\" 'change path to suit
    fFiles = Split(CreateObject("WScript.Shell").Exec("cmd /c Dir """ & fPath & "*.xls?"" /b").StdOut.ReadAll, vbCrLf)
    ConsSheet = Array("test", "test2", "test3", "test4", "test5", "apple", "cancer", "cop") 'change sheet names to suit
    
    On Error Resume Next
    
    For j = LBound(fFiles) To UBound(fFiles) - 1
        Workbooks.Open (fPath & fFiles(j))
        With ActiveWorkbook
            For i = LBound(ConsSheet) To UBound(ConsSheet)
                With .Worksheets(ConsSheet(i))
                    .Cells(1).AutoFilter Field:=2, Criteria1:=RGB(255, 0, 0), Operator:=xlFilterFontColor
                    .AutoFilter.Range.Offset(1).SpecialCells(12).Copy
                    ThisWorkbook.Worksheets(ConsSheet(i)).Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
                End With
            Next i
            .Close 0
        End With
    Next j
    
    With Application
        .EnableEvents = True
        .AskToUpdateLinks = True
        .Calculation = calc
    End With

End Sub

[k0st4din]

Hello,
many thanks for the quick response, but the macro does not work for me, ie from each sheet not copy and carries red (new) information.
Second, can I do so that when I opened my file, when I press me button, to choose from which files can be transferred (accumulates) information (ie in the base sheet) not to transfer all excel files in the selected excel folder?
Please watch the video, I think it will best understand what I mean
https://youtu.be/aoLil8Ny-QU;;;;;;;;;; https://youtu.be/ZR4sGq5mEGo
Another detail not know if I dabble may itself be such a macro, but in every one sheet I have a different number of rows of red information.
It comes to this line in the macro that displays 12 (correct?)

.AutoFilter.Range.Offset(1).SpecialCells(12).Copy

[mancubus]

after testing with the files you uploaded, i posted the the code.

make sure red font is RGB(255, 0, 0) in all sheets.

i modified the code for selecting the files and testing if there are filtered rows.

[mancubus]

Sub vbax_58805_cons_sheets()
     
    Dim fPath As String
    Dim fFiles, ConsSheet
    Dim i As Long, j As Long, calc As Long
     
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
        .EnableEvents = False
        .AskToUpdateLinks = False
        calc = .Calculation
        .Calculation = xlCalculationManual
    End With
     
    ConsSheet = Array("test", "test2", "test3", "test4", "test5", "apple", "cancer", "cop") 'change sheet names to suit
    
    With Application.FileDialog(msoFileDialogFilePicker)
        .InitialFileName = ThisWorkbook.Path & "\" 'you may replace this with desired folder path
        .InitialView = msoFileDialogViewList
        .AllowMultiSelect = True
        If .Show = -1 Then
            ReDim fFiles(1 To .SelectedItems.Count)
            For i = 1 To .SelectedItems.Count
                fFiles(i) = .SelectedItems(i)
            Next i
        End If
    End With
            
    On Error Resume Next
     
    For j = LBound(fFiles) To UBound(fFiles)
        Workbooks.Open fFiles(j)
        With ActiveWorkbook
            For i = LBound(ConsSheet) To UBound(ConsSheet)
                With .Worksheets(ConsSheet(i))
                    .Cells(1).AutoFilter Field:=2, Criteria1:=RGB(255, 0, 0), Operator:=xlFilterFontColor
                    If .AutoFilter.Range.SpecialCells(12).Rows.Count > 1 Then
                        .AutoFilter.Range.Offset(1).SpecialCells(12).Copy
                        ThisWorkbook.Worksheets(ConsSheet(i)).Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
                    End If
                End With
            Next i
            .Close 0
        End With
    Next j
     
    With Application
        .EnableEvents = True
        .AskToUpdateLinks = True
        .Calculation = calc
    End With
     
End Sub

[k0st4din]

https://youtu.be/QWCwfzxAHko
Hello
I think we're almost to the finish.
Please look at the video you will see that everything should've done, but information is copied only in sheet named "test2".
Where am I wrong?
P.S. - Just to mention that in each sheet can have different number of red lines, they are not constant, can also not one red line (depending on whether there are sales)

[mancubus]

as per our corporate internet policy, access to youtube and other social media is denied.
even it's allowed, i'm not sure i'll watch it.
explain your requirement here.

the code takes into account zero or multiple red rows.

try to understand what the code is doing and adopt it to your case.

if you can't do it, upload more realistic files so i can work with them.

[k0st4din]

OK, we have two files;

1 - my (BASE)
2 - (Received)

In my (BASE) file is to carry all the information accumulated by the (Received).
In the file Base I have many sheets
for example:
test1
test2
test3
test4
test5
etc


In the Received file again have the same names sheets
test1 -> all filtered in red text from column B must be transferred to the BASE file name, from A:to the end in the list of test1, with accumulation, if no red text move to the next sheet
test2 -> all filtered in red text from column B must be transferred to the BASE file name, from A:to the end in the list of test2 with accumulation, if no red text move to the next sheet
test3 -> all filtered in red text from column B must be transferred to the BASE file name, from A:to the end in the list of test3, with accumulation, if no red text move to the next sheet
test4 -> all filtered in red text from column B must be transferred to the BASE file name, from A:to the end in the list of test4, with accumulation, if no red text move to the next sheet
test5 -> all filtered in red text from column B must be transferred to the BASE file name, from A:to the end in the list of test5, with accumulation, if no red text move to the next sheet
etc
I will attach three files:
BASE
RECEIVED (copy from here and paste special value, in same name sheet in BASE file)
and the final result File
I remain available and thanks in advance.

[mancubus]

i modified the code to work with single file.

below code exactly convert the base.xlsm to final.xlsm

therefore this is my LAST post to the thread.

Sub vbax_58805_cons_sheets_single_multi_files()
     
    Dim fPath As String, FileToOpen As String
    Dim fFiles, ConsSheet
    Dim i As Long, j As Long, calc As Long
     
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
        .EnableEvents = False
        .AskToUpdateLinks = False
        calc = .Calculation
        .Calculation = xlCalculationManual
    End With
     
    ConsSheet = Array("test", "test2", "test3", "test4", "test5") 'change sheet names to suit
     
    With Application.FileDialog(msoFileDialogFilePicker)
        .InitialFileName = "" 'you may replace this with desired folder path
        .InitialView = msoFileDialogViewList
        .AllowMultiSelect = True
        If .Show = -1 Then
            If .SelectedItems.Count = 1 Then
                FileToOpen = .SelectedItems(1)
                GoTo Single_File
            Else
                ReDim fFiles(1 To .SelectedItems.Count)
                For i = 1 To .SelectedItems.Count
                    fFiles(i) = .SelectedItems(i)
                Next i
                GoTo Multi_File
            End If
        End If
    End With
     
Single_File:
    On Error Resume Next
    
    Workbooks.Open (FileToOpen)
    With ActiveWorkbook
        For i = LBound(ConsSheet) To UBound(ConsSheet)
            With .Worksheets(ConsSheet(i))
                .Cells(1).AutoFilter Field:=2, Criteria1:=RGB(255, 0, 0), Operator:=xlFilterFontColor
                .AutoFilter.Range.Offset(1).SpecialCells(12).Copy
                ThisWorkbook.Worksheets(ConsSheet(i)).Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues 'xlPasteAll if you want to see red fonts'
            End With
        Next i
        .Close 0
    End With
GoTo Single_File_Exit
     
Multi_File:
    On Error Resume Next
    
    For j = LBound(fFiles) To UBound(fFiles)
        Workbooks.Open fFiles(j)
        With ActiveWorkbook
            For i = LBound(ConsSheet) To UBound(ConsSheet)
                With .Worksheets(ConsSheet(i))
                    .Cells(1).AutoFilter Field:=2, Criteria1:=RGB(255, 0, 0), Operator:=xlFilterFontColor
                    If .AutoFilter.Range.SpecialCells(12).Rows.Count > 1 Then
                        .AutoFilter.Range.Offset(1).SpecialCells(12).Copy
                        ThisWorkbook.Worksheets(ConsSheet(i)).Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
                    End If
                End With
            Next i
            .Close 0
        End With
    Next j
     
Single_File_Exit:
    
    With Application
        .EnableEvents = True
        .AskToUpdateLinks = True
        .Calculation = calc
    End With
     
End Sub

[k0st4din]

Hello
this macro is exactly what I needed.
Little is if you say cordially thank you.
I'm glad there are people like you who help us in these situations.
Be alive and well and still responsive.
Thanks once again.

[mancubus]

you are welcome.
mark the thread as solved from thread tools pls.