Copy specific cells from one worksheet to another worksheet

**jos283** · 07-24-2017, 08:33 AM

Hi everyone, need some help with this VBA code!

What I want to do is copy cells from a worksheet (i.e. "Input") to another worksheet (i.e. "Output") when a specific variable is entered into a specific column.

Whenever a "1" is entered by a user (in Yes/No i.e. E, J, O etc.), I want the code to copy the matching varible under table name (in column B, G, L) to a new worksheet where these variables will form a new table for all entries with a "1" entered. I have attached an Excel sheet and the output should look like the new worksheet "Output" after the code is run. Obviously it would be blank to begin with as nothing is changed from 0 to 1 yet. The new worksheet should update automatically in real time when 0's and 1's are entered into "Input", so there shouldn't need to create a button.

Aside from the Yes/No column, there is a Low and High column for Tables 9, 10, 11. For these, it should only look the data inputted into the 8th row, i.e. AU8, AV8, AZ8, BA8, BE8, and BF8. And rather than taking only "1", these cells should take any number (even 0) as long as Low and High are different. If they are the same, then don't move either to "Output" worksheet because no numerical range is being selected.

Any help on the code is much appreciated!

The code below is what I've tried to do so far, but it obviously hasn't worked.

In Module:

Option Explicit

Sub Filter()
Dim rng1, rng2, rng3, rng4, rng5, rng6, rng7, rng8, _
rng9, rng10, rng11, rng12, rng13, rng14, cell, fndRng As Range
Dim Start, Finish As Worksheet
Dim nrow, col  As Long
Dim Val As String
Application.ScreenUpdating = False
Sheets("Input").Range("A2:B5000").ClearContents
Set Start = Sheets("Input"): Set Finish = Sheets("Output")
With Start
    Set rng1 = .Range("E8:E" & .Cells(Rows.Count, "E").End(xlUp).Row)
    Set rng2 = .Range("J8:J" & .Cells(Rows.Count, "J").End(xlUp).Row)
    Set rng3 = .Range("O8:O" & .Cells(Rows.Count, "O").End(xlUp).Row)
    Set rng4 = .Range("U8:U" & .Cells(Rows.Count, "U").End(xlUp).Row)
    Set rng5 = .Range("Z8:Z" & .Cells(Rows.Count, "Z").End(xlUp).Row)
    Set rng6 = .Range("AF8:AF" & .Cells(Rows.Count, "AF").End(xlUp).Row)
    Set rng7 = .Range("AL8:AL" & .Cells(Rows.Count, "AL").End(xlUp).Row)
    Set rng8 = .Range("AQ8:AQ" & .Cells(Rows.Count, "AQ").End(xlUp).Row)
    Set rng9 = .Range("AU8" & .Cells(Rows.Count, "AU").End(xlUp).Row)
    Set rng10 = .Range("AV8" & .Cells(Rows.Count, "AV").End(xlUp).Row)
    Set rng11 = .Range("AZ8" & .Cells(Rows.Count, "AZ").End(xlUp).Row)
    Set rng12 = .Range("BA8" & .Cells(Rows.Count, "BA").End(xlUp).Row)
    Set rng13 = .Range("BE8" & .Cells(Rows.Count, "BE").End(xlUp).Row)
    Set rng14 = .Range("BF8" & .Cells(Rows.Count, "BF").End(xlUp).Row)
    For Each cell In Union(rng1, rng2, rng3, rng4, rng5, rng6, rng7, _
    rng8, rng9, rng10, rng11, rng12, rng13, rng14)
        Val = cell.Offset(, -1)
        If cell = "1" Then
            col = cell.Column
            With Finish
                With .Range("B:B")
                    Set fndRng = .Find(Val, LookIn:=xlValues, lookat:=xlWhole)
                End With
                If fndRng Is Nothing Then
                     nrow = .Cells(Rows.Count, "A").End(xlUp).Row + 1
                    .Range("A" & nrow) = Start.Cells(1, col - 1)
                    .Range("B" & nrow) = cell.Offset(0, -1)
                End If
            End With
        ElseIf cell = "0" Then
            With Finish
                With .Range("B:B")
                    Set fndRng = .Find(Val, LookIn:=xlValues, lookat:=xlWhole)
                End With
                If Not fndRng Is Nothing Then
                    fndRng.EntireRow.Delete
                End If
            End With
        End If
    Next cell
End With
Application.ScreenUpdating = True
End Sub

-------
In Sheet 1 ("Input"):

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 5 Or Target.Column = 10 Or Target.Column = 15 _
Or Target.Column = 20 Or Target.Column = 25 Or Target.Column = 30 _
Or Target.Column = 35 Or Target.Column = 40 Or Target.Column = 44 _
Or Target.Column = 45 Or Target.Column = 49 Or Target.Column = 50 _
Or Target.Column = 54 Or Target.Column = 55 Then
    Call Filter
End If
End Sub

**davesexcel** · 07-24-2017, 09:27 AM

Probably just setting it up for each target.range would work as well

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Sh As Worksheet, LstRw As Long
    Set Sh = Sheets("Output")

    If Target.Count > 1 Then Exit Sub    ' this stops code error if more than one cell is changed at once
    '---------table1
    If Not Application.Intersect(Target, Me.Range("E8:E100")) Is Nothing Then    ' indicates the Target range
        With Sh
            LstRw = .Cells(.Rows.Count, "B").End(xlUp).Row + 1
            .Cells(LstRw, 2) = "Table 1"
            .Cells(LstRw, 3) = Target.Offset(, -3)
        End With
    End If
    '-----table 2
    If Not Application.Intersect(Target, Me.Range("J8:J100")) Is Nothing Then    ' indicates the Target range
        With Sh
            LstRw = .Cells(.Rows.Count, "B").End(xlUp).Row + 1
            .Cells(LstRw, 2) = "Table 2"
            .Cells(LstRw, 3) = Target.Offset(, -3)
        End With
    End If
    '-----table 3
    If Not Application.Intersect(Target, Me.Range("O8:O100")) Is Nothing Then    ' indicates the Target range
        With Sh
            LstRw = .Cells(.Rows.Count, "B").End(xlUp).Row + 1
            .Cells(LstRw, 2) = "Table 3"
            .Cells(LstRw, 3) = Target.Offset(, -3)
        End With
    End If



End Sub

By the way,

Dim rng1, rng2, rng3, rng4, rng5, rng6, rng7, rng8, _
rng9, rng10, rng11, rng12, rng13, rng14, cell, fndRng As Range

The only variable properly set as a range would be fndRng, everything else would not be considered ranges.

Dim rng1 as range,rng2 as range,rng3 as range......................etc..

**sintek** · 07-24-2017, 09:59 AM

Hey jos283...well done...You were very close...
Try this...

Option Explicit

Sub FilterSummary()
Dim rng1 As Range, rng2 As Range, rng3 As Range, rng4 As Range, rng5 As Range, _
rng6 As Range, rng7 As Range, rng8 As Range, rng9 As Range, rng10 As Range, _
rng11 As Range, cell As Range
Dim Start As workSheet, Finish As Worksheet
Dim nrow as Long, col  As Long
Dim tbl As String, Val  As String
Application.ScreenUpdating = False
Set Start = Sheets("Input"): Set Finish = Sheets("Output")
Finish.Range("B3:D5000").ClearContents
With Start
    Set rng1 = .Range("E8:E" & .Cells(Rows.Count, "E").End(xlUp).Row)
    Set rng2 = .Range("J8:J" & .Cells(Rows.Count, "J").End(xlUp).Row)
    Set rng3 = .Range("O8:O" & .Cells(Rows.Count, "O").End(xlUp).Row)
    Set rng4 = .Range("U8:U" & .Cells(Rows.Count, "U").End(xlUp).Row)
    Set rng5 = .Range("Z8:Z" & .Cells(Rows.Count, "Z").End(xlUp).Row)
    Set rng6 = .Range("AF8:AF" & .Cells(Rows.Count, "AF").End(xlUp).Row)
    Set rng7 = .Range("AL8:AL" & .Cells(Rows.Count, "AL").End(xlUp).Row)
    Set rng8 = .Range("AQ8:AQ" & .Cells(Rows.Count, "AQ").End(xlUp).Row)
    Set rng9 = .Range("AU8:AV" & .Cells(Rows.Count, "AV").End(xlUp).Row)
    Set rng10 = .Range("AZ8:BA" & .Cells(Rows.Count, "BA").End(xlUp).Row)
    Set rng11 = .Range("BE8:BF" & .Cells(Rows.Count, "BF").End(xlUp).Row)
    
    For Each cell In Union(rng1, rng2, rng3, rng4, rng5, rng6, rng7, rng8)
        If cell = "1" Then
            col = cell.Offset(, -3).Column
            tbl = .Cells(7, col)
            Val = cell.Offset(, -3)
            With Finish
                nrow = .Cells(Rows.Count, "B").End(xlUp).Row + 1
                .Range("B" & nrow) = tbl
                .Range("C" & nrow) = Val
            End With
        End If
    Next cell
    For Each cell In Union(rng9, rng10, rng11)
        If cell >= 0 And cell.Offset(, 1) > cell Then
            col = cell.Offset(, -2).Column
            tbl = .Cells(7, col)
            With Finish
                nrow = .Cells(Rows.Count, "B").End(xlUp).Row + 1
                .Range("B" & nrow) = tbl
                .Range("C" & nrow) = cell
                .Range("D" & nrow) = cell.Offset(, 1)
            End With
        End If
    Next cell
End With
Application.ScreenUpdating = True
End Sub

Keep your worksheet code as is...

Edit:
As per davesexcel....all the other rng's will be declared as Variant which generally will be accepted until it bombs out somewhere.

PS...What about the sample workbook in this post...Is it the same requirement but is this the original file..
https://www.excelforum.com/excel-pro...ml#post4702759

**jos283** · 07-24-2017, 02:01 PM

Sintek -

Yes, pretty much the same thing but an extended version of it with a few extra criteria.

Thanks, I've adjusted it to suit my requirements but the code works again!

**jos283** · 07-25-2017, 12:38 PM

For the final 3 tables:

Output.png

**sintek** · 07-25-2017, 01:24 PM

Option Explicit

Sub FilterSummary()
Dim rng1 As Range, rng2 As Range, rng3 As Range, rng4 As Range, rng5 As Range, _
rng6 As Range, rng7 As Range, rng8 As Range, rng9 As Range, rng10 As Range, _
rng11 As Range, cell As Range
Dim Start As Worksheet, Finish As Worksheet
Dim nrow As Long, col  As Long
Dim tbl As String, Val  As String
Application.ScreenUpdating = False
Set Start = Sheets("Input"): Set Finish = Sheets("Output")
Finish.Range("B3:D5000").ClearContents
With Start
    Set rng1 = .Range("E8:E" & .Cells(Rows.Count, "E").End(xlUp).Row)
    Set rng2 = .Range("J8:J" & .Cells(Rows.Count, "J").End(xlUp).Row)
    Set rng3 = .Range("O8:O" & .Cells(Rows.Count, "O").End(xlUp).Row)
    Set rng4 = .Range("U8:U" & .Cells(Rows.Count, "U").End(xlUp).Row)
    Set rng5 = .Range("Z8:Z" & .Cells(Rows.Count, "Z").End(xlUp).Row)
    Set rng6 = .Range("AF8:AF" & .Cells(Rows.Count, "AF").End(xlUp).Row)
    Set rng7 = .Range("AL8:AL" & .Cells(Rows.Count, "AL").End(xlUp).Row)
    Set rng8 = .Range("AQ8:AQ" & .Cells(Rows.Count, "AQ").End(xlUp).Row)
    Set rng9 = .Range("AU8:AV" & .Cells(Rows.Count, "AV").End(xlUp).Row)
    Set rng10 = .Range("AZ8:BA" & .Cells(Rows.Count, "BA").End(xlUp).Row)
    Set rng11 = .Range("BE8:BF" & .Cells(Rows.Count, "BF").End(xlUp).Row)
    
    For Each cell In Union(rng1, rng2, rng3, rng4, rng5, rng6, rng7, rng8)
        If cell = "1" Then
            col = cell.Offset(, -3).Column
            tbl = .Cells(7, col)
            Val = cell.Offset(, -3)
            With Finish
                nrow = .Cells(Rows.Count, "B").End(xlUp).Row + 1
                .Range("B" & nrow) = tbl
                .Range("C" & nrow) = Val
            End With
        End If
    Next cell
    For Each cell In Union(rng9, rng10, rng11)
        If cell >= 0 And cell.Offset(, 1) > cell Then
            col = cell.Offset(, -2).Column
            tbl = .Cells(7, col)
            With Finish
                nrow = .Cells(Rows.Count, "B").End(xlUp).Row + 1
                col = cell.Column
                .Range("B" & nrow) = tbl & "_Low"
                .Range("C" & nrow) = cell
                .Range("B" & nrow + 1) = tbl & "_High"
                .Range("C" & nrow + 1) = cell.Offset(, 1)
            End With
        End If
    Next cell
End With
Application.ScreenUpdating = True
End Sub

**Winon** · 07-25-2017, 05:54 PM

Hello jos283,

Do you know if there is a way to get the output to look like this so that the table only uses two columns instead of three

That is where the problem lies. With the conditions set for the Min and Max conditions.

B.t.w. this Code of yours below;

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 5 Or Target.Column = 10 Or Target.Column = 15 _
Or Target.Column = 20 Or Target.Column = 25 Or Target.Column = 30 _
Or Target.Column = 35 Or Target.Column = 40 Or Target.Column = 44 _
Or Target.Column = 45 Or Target.Column = 49 Or Target.Column = 50 _
Or Target.Column = 54 Or Target.Column = 55 Then
    Call Filter
End If
End Sub

Should actually read;

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 5 Or Target.Column = 10 Or Target.Column = 15 _
Or Target.Column = 21 Or Target.Column = 26 Or Target.Column = 32 _
Or Target.Column = 38 Or Target.Column = 43 Or Target.Column = 47 _
Or Target.Column = 48 Or Target.Column = 52 Or Target.Column = 53 _
Or Target.Column = 57 Or Target.Column = 58 Then
    Call FilterSummary
End If
End Sub

Regards.

**jos283** · 07-25-2017, 06:24 PM

Thanks, spotted that!

Copy specific cells from one worksheet to another worksheet

LinkBack

Thread Tools

Rate This Thread

Display

Hybrid View

Copy specific cells from one worksheet to another worksheet

Re: Copy specific cells from one worksheet to another worksheet

Re: Copy specific cells from one worksheet to another worksheet

Re: Copy specific cells from one worksheet to another worksheet

Re: Copy specific cells from one worksheet to another worksheet

Re: Copy specific cells from one worksheet to another worksheet

Re: Copy specific cells from one worksheet to another worksheet

Re: Copy specific cells from one worksheet to another worksheet

Thread Information

Users Browsing this Thread

Similar Threads

[SOLVED] Copy specific cells from one worksheet to another worksheet

[SOLVED] VBA to copy paste to specific worksheet from another workbook of same worksheet name

How to copy specific cell values in worksheet to another worksheet in the same workbook?

Macro to copy specific cells from diff worksheet

Copy ranges and specific cells into one worksheet

Macro to copy six specific columns from one worksheet to another worksheet

Copy Specific Cells To Another Worksheet

Bookmarks

Bookmarks

Posting Permissions