Copy data from multiple worksheets to one sheet

[kaydee1]

hi guys, I am new to VBA and I need help copying data from multiple worksheets to a single sheet in the same workbook.
my workbook has 12 worksheets named by their moths. each worksheet has a number of rows that gets updated. please note that some fields of "Importer" are blank. for each worksheet I need to copy all mass values less than 20 and paste them to a new sheet called "under20", and transfer the rest to "over20".

your help will be much appreciated

worksheet 1 : 2017-04

Importer	Month	Origin	Mass	Price
Importer 1	April-17	MZ	100	90
Importer 2	April-17	ZM	50	30
Importer 3	April-17	IN	20	19
Importer 1	April-17	MZ	200	150
	April-17	GB	20	18

<tbody>
</tbody>

worksheet 12 : 2018-03

Importer	Month	Origin	Mass	Value
Importer 1	March -17	MZ	300	240
Importer 5	March -17	GB	10	9
Importer 2	March -17	ZM	60	50
	March -17	SY	11	8

<tbody>
</tbody>

 

[Yongle]

Welcome to the forum

Test this in a COPY of your workbook
- assumes that the workbook contains only monthly sheets and that first header is in cell A1 in all sheets
- the VBA creates the 2 new sheets required

You stated that Importer is sometimes blank
- but gave no reason
- so assumption is that is how they should remain

You said I need to copy all mass values less than 20 and paste them to a new sheet called "under20", and transfer the rest to "over20"
- what about = 20 ?
- I have include in the "over 20" sheet

Sub ConsolSheets()
    Dim ws1 As Worksheet, ws2 As Worksheet, copyRng As Range, pasteRng As Range, Rng As Range, s As Long
    Set ws1 = Sheets.Add(Before:=Sheets(1)): ws1.Name = "Over 20"
        With Sheets(2).Range("A1").CurrentRegion.Resize(1)
            .Copy ws1.Cells(1)
            .Copy:  ws1.Cells(1).PasteSpecial (xlPasteColumnWidths)
        End With
        On Error Resume Next
        For s = 2 To ThisWorkbook.Sheets.Count
            Set copyRng = Sheets(s).Range("A1").CurrentRegion.Offset(1)
            Set pasteRng = ws1.Range("A1").CurrentRegion
            Set pasteRng = pasteRng.Offset(pasteRng.Rows.Count).Resize(1, 1)
            copyRng.Copy pasteRng
        Next s
    
        ws1.Copy Before:=Sheets(1): Set ws2 = Sheets(1):  ws2.Name = "Under 20"
    
        Set Rng = ws2.Range("A1").CurrentRegion.Offset(1)
        ws2.Range("A:E").AutoFilter Field:=4, Criteria1:=">=20"
        Rng.SpecialCells(xlCellTypeVisible).EntireRow.Delete
        ws2.ShowAllData
    
        Set Rng = ws1.Range("A1").CurrentRegion.Offset(1)
        ws1.Range("A:E").AutoFilter Field:=4, Criteria1:="<20"
        Rng.SpecialCells(xlCellTypeVisible).EntireRow.Delete
        ws1.ShowAllData
End Sub

The VBA
- creates a new sheet
- copies ALL values to new sheet
- duplicates new sheet
- deletes under20s from one and over20s from the other

 

[kaydee1]

Thank you very much, i like your summary its exactly what i need. it worked without any problems.

 

[Yongle]

thanks for feedback