PDA

View Full Version : [SOLVED] transfer of information from identical excel files and identical sheets of accumulati



k0st4din
03-06-2017, 01:24 PM
Hello, everyone,
I asked for help on this site (https://www.mrexcel.com/forum/excel-questions/994066-application-information-same-workbooks-but-one-primary-other-working.html), 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 (https://www.sendspace.com/file/o5rtwa)
Received file (https://www.sendspace.com/file/lwbg7o)
Final results (https://www.sendspace.com/file/rtmmt7)
Thank you in advance for your assistance.
I wish you good health.

k0st4din
03-08-2017, 07:43 AM
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
03-08-2017, 08:45 AM
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
03-08-2017, 09:21 AM
Thank you in advance for your assistance.

k0st4din
03-12-2017, 10:00 PM
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
03-13-2017, 04:16 AM
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
03-13-2017, 04:51 AM
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
03-13-2017, 09:02 AM
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
03-13-2017, 01:12 PM
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
03-13-2017, 01:15 PM
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
03-13-2017, 10:14 PM
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
03-13-2017, 11:14 PM
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
03-14-2017, 10:27 AM
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
03-15-2017, 12:33 AM
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
03-15-2017, 07:53 PM
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
03-16-2017, 05:47 AM
you are welcome.
mark the thread as solved from thread tools pls.