Copy Wrksheet range in VBA consolidation

[michellebenton2012]

Hi,

I am working on a marco and have a few kinks I need to work through. So far I am able to copy all the sheets I want to into one sheet. I am not trying to copy only certain columns from those sheets as well as apply an autofilter to copy only to rows that are "Active".

here is my code:

Private Sub Worksheet_Activate()
'Consolidates data from the range B6:Q2215 for every tab except the one it's part of.
Dim wrkSheet As Worksheet
Dim rngCopy As Range
Dim lngPasteRow As Long
Dim strConsTab As String

strConsTab = ActiveSheet.Name 'Consolidation sheet tab name based on active tab.

If Sheets(strConsTab).Cells(Rows.Count, "B").End(xlUp).Row >= 2 Then
If MsgBox("Do you want to clear the existing consolidated data in """ & strConsTab & """", vbQuestion + vbYesNo, "Data Consolidation Editor") = vbYes Then
Sheets(strConsTab).Range("B6:Q" & Cells(Rows.Count, "B").End(xlUp).Row).ClearContents
End If
End If

Application.ScreenUpdating = False

For Each wrkSheet In ActiveWorkbook.Worksheets


If wrkSheet.Name <> strConsTab And wrkSheet.Name <> "Inactive" And wrkSheet.Name <> "Head Count" And wrkSheet.Name <> "Colombia" And wrkSheet.Name <> "China JV" And wrkSheet.Name <> "Sustain" And wrkSheet.Name <> "AMS" Then


Set rngCopy = wrkSheet.Range("B:B, E:E, G:J,L:L, N:N, Q:Q, R:R")
lngPasteRow = Sheets(strConsTab).Cells(Rows.Count, "B").End(xlUp).Row + 1
rngCopy.Copy Sheets(strConsTab).Range("B" & lngPasteRow)
Application.CutCopyMode = False

End If


Next

End Sub



The red area above designated the columns I want to copy over. It says the copy are and paste area are not the same size and highlights this code:rngCopy.Copy Sheets(strConsTab).Range("B" & lngPasteRow)


I am still not even sure how to use the auto filters to filter on column 8 criteria = "A"


Please help thanks!

 

[AlphaFrog]

Try something like this...

[color=darkblue]Private[/color] [color=darkblue]Sub[/color] Worksheet_Activate()
    [color=green]'Consolidates data from the range B6:Q2215 for every tab except the one it's part of.[/color]
    [color=darkblue]Dim[/color] ws [color=darkblue]As[/color] Worksheet
    [color=darkblue]Dim[/color] LastRow [color=darkblue]As[/color] [color=darkblue]Long[/color]
    
    [color=darkblue]If[/color] Cells(Rows.Count, "B").End(xlUp).Row >= 2 [color=darkblue]Then[/color]
        [color=darkblue]If[/color] MsgBox("Do you want to clear the existing consolidated data in """ & Me.Name & """", vbQuestion + vbYesNo, "Data Consolidation Editor") = vbYes [color=darkblue]Then[/color]
            Range("B6:Q" & Cells(Rows.Count, "B").End(xlUp).Row).ClearContents
        [color=darkblue]End[/color] [color=darkblue]If[/color]
    [color=darkblue]End[/color] [color=darkblue]If[/color]
    
    Application.ScreenUpdating = [color=darkblue]False[/color]
    [color=darkblue]For[/color] [color=darkblue]Each[/color] ws [color=darkblue]In[/color] Worksheets
    
        [color=darkblue]If[/color] InStr("Inactive|Head Count|Colombia|China JV|Sustain|AMS|" & Me.Name, ws.Name) = 0 [color=darkblue]Then[/color]
            
            LastRow = ws.Cells(Rows.Count, "B").End(xlUp).Row
            [color=darkblue]If[/color] IsNumeric(Application.Match("A", ws.Range("H2:H" & LastRow), 0)) [color=darkblue]Then[/color]
                ws.Range("A1:H" & LastRow).AutoFilter 8, "A"
                Intersect(ws.Range("A2:R" & LastRow), ws.Range("B:B,E:E,G:J,L:L,N:N,Q:Q,R:R")).Copy _
                    Cells(Rows.Count, "B").End(xlUp).Offset(1)
                ws.AutoFilterMode = [color=darkblue]False[/color]
            [color=darkblue]End[/color] [color=darkblue]If[/color]
            
        [color=darkblue]End[/color] [color=darkblue]If[/color]
    
    [color=darkblue]Next[/color]
    Application.ScreenUpdating = [color=darkblue]True[/color]
    
[color=darkblue]End[/color] [color=darkblue]Sub[/color]

 

[michellebenton2012]

Hi,

Thanks for your response, however the first time i tried using the code it copied over blank cells. the second time I messed with it it said"
LastRow = wrkSheet.Cells(Rows.Count, "B6").End(xlUp).Row
If IsNumeric(Application.Match("A", wrkSheet.Range("L2:L" & LastRow), 0)) Then
wrkSheet.Range("A1:L" & LastRow).AutoFilter 12, "A""
-application definied or object defined error. column H has three options "I, F, or A" I need to copy over only the A rows to the consolidated worksheet. I also need to only copy the columns B,E, G, J, L. N. Q, R (The wrksheets have the same headings/cell placement on each page and starts on B6)


PLEASE HELP



Private Sub Worksheet_Activate()
'Consolidates data from the range B6:Q2215 for every tab except the one it's part of.
Dim wrkSheet As Worksheet
Dim rngCopy As Range
Dim lngPasteRow As Long
Dim strConsTab As String

strConsTab = ActiveSheet.Name 'Consolidation sheet tab name based on active tab.

If Sheets(strConsTab).Cells(Rows.Count, "B").End(xlUp).Row >= 2 Then
If MsgBox("Do you want to clear the existing consolidated data in """ & strConsTab & """", vbQuestion + vbYesNo, "Data Consolidation Editor") = vbYes Then
Sheets(strConsTab).Range("B6:Q" & Cells(Rows.Count, "B").End(xlUp).Row).ClearContents
End If
End If

Application.ScreenUpdating = False


For Each wrkSheet In ActiveWorkbook.Worksheets

If InStr("Inactive|Head Count|Colombia|China JV|Sustain|AMS|" & ActiveSheet.Name, wrkSheet.Name) = 0 Then

LastRow = wrkSheet.Cells(Rows.Count, "B6").End(xlUp).Row
If IsNumeric(Application.Match("A", wrkSheet.Range("L2:L" & LastRow), 0)) Then
wrkSheet.Range("A1:L" & LastRow).AutoFilter 12, "A"
Intersect(wrkSheet.Range("A2:R" & LastRow), wrksheets.Range("B:B,E:E,G:J,L:L,N:N,Q:Q,R:R")).Copy _
Cells(Rows.Count, "B6").End(xlUp).Offset(1)
ws.AutoFilterMode = False
End If

End If

Next

Application.ScreenUpdating = True

End Sub

 

[AlphaFrog]

Please surround your code with

 tags. It makes reading your code much easier. See my signature block below.

Place this code in the destination worksheet's code module. Right-click on the sheet tab and select [I]View Code[/I]. The [I]Me[/I] in the code is a VBA sheet reference to the destination worksheet.

[CODE][COLOR=darkblue]Private[/COLOR] [COLOR=darkblue]Sub[/COLOR] Worksheet_Activate()
    [COLOR=green]'Consolidates data from the range B6:Q2215 for every tab except the one it's part of.[/COLOR]
    [COLOR=darkblue]Dim[/COLOR] ws [COLOR=darkblue]As[/COLOR] Worksheet
    [COLOR=darkblue]Dim[/COLOR] LastRow [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]Long[/COLOR]
    
    [COLOR=darkblue]If[/COLOR] Cells(Rows.Count, "B").End(xlUp).Row >= 2 [COLOR=darkblue]Then[/COLOR]
        [COLOR=darkblue]If[/COLOR] MsgBox("Do you want to clear the existing consolidated data in """ & Me.Name & """", vbQuestion + vbYesNo, "Data Consolidation Editor") = vbYes [COLOR=darkblue]Then[/COLOR]
            Range("B6:Q" & Cells(Rows.Count, "B").End(xlUp).Row).ClearContents
        [COLOR=darkblue]End[/COLOR] [COLOR=darkblue]If[/COLOR]
    [COLOR=darkblue]End[/COLOR] [COLOR=darkblue]If[/COLOR]
    
    Application.ScreenUpdating = [COLOR=darkblue]False[/COLOR]
    [COLOR=darkblue]For[/COLOR] [COLOR=darkblue]Each[/COLOR] ws [COLOR=darkblue]In[/COLOR] Worksheets
    
        [COLOR=darkblue]If[/COLOR] InStr("Inactive|Head Count|Colombia|China JV|Sustain|AMS|" & Me.Name, ws.Name) = 0 [COLOR=darkblue]Then[/COLOR]
            
            LastRow = ws.Cells(Rows.Count, "B").End(xlUp).Row   [COLOR=green]'last used cell in column B on each worksheet[/COLOR]
            [COLOR=darkblue]If[/COLOR] LastRow > 6 [COLOR=darkblue]Then[/COLOR]
                [COLOR=darkblue]If[/COLOR] IsNumeric(Application.Match("A", ws.Range("L6:L" & LastRow), 0)) [COLOR=darkblue]Then[/COLOR]    [COLOR=green]'Test if column L has any "A" values[/COLOR]
                    ws.Range("A6:R" & LastRow).AutoFilter 12, "A"   [COLOR=green]'Autofilter column L where row 6 is the header row[/COLOR]
                    [COLOR=green]' Copy filtered values from specific columns to destination worksheet[/COLOR]
                    Intersect(ws.Range("A7:R" & LastRow), ws.Range("B:B,E:E,G:J,L:L,N:N,Q:Q,R:R")).Copy _
                        Me.Cells(Rows.Count, "B").End(xlUp).Offset(1)
                    ws.AutoFilterMode = [COLOR=darkblue]False[/COLOR]
                [COLOR=darkblue]End[/COLOR] [COLOR=darkblue]If[/COLOR]
            [COLOR=darkblue]End[/COLOR] [COLOR=darkblue]If[/COLOR]
            
        [COLOR=darkblue]End[/COLOR] [COLOR=darkblue]If[/COLOR]
    
    [COLOR=darkblue]Next[/COLOR]
    Application.ScreenUpdating = [COLOR=darkblue]True[/COLOR]
    
[COLOR=darkblue]End[/COLOR] [COLOR=darkblue]Sub[/COLOR]