Copy rows from one sheet to another based on cell value

C

craigg3

Board Regular
Joined
Dec 23, 2002
Messages
161
Office Version
  1. 2013
Platform
  1. Windows
I need to copy and paste rows from one sheet to another if the cell value in column B = Bills

Starting on sheet ("iState") at B3, if the cell = Bills, then I need it to copy that whole row to sheet("iSummary") starting on row 3

and then I need it to move to B4 and copy and paste f that cell value = Bill...

and continue until it gets to the end of iState sheet which will usually be about 250 records give or take. I played around with some code but wasn't getting anywhere with what I had. Thanks.
 
Sort by date Sort by votes
What is the password for the Data Entry workbook?
 
Upvote 0

Excel Facts

Return population for a City
If you have a list of cities in A2:A100, use Data, Geography. Then =A2.Population and copy down.
Replace the current Worksheet_Change macro with the one below. Make sure that both workbooks are open.
VBA Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Oldvalue As String, Newvalue As String, desWS As Worksheet
    Application.EnableEvents = True
    If Intersect(Target, Range("G:G,BK:BK,BR:BR")) Is Nothing Then Exit Sub
    On Error GoTo Exitsub
    Select Case Target.Column
        Case Is = 63, 70
            If Target.SpecialCells(xlCellTypeAllValidation) Is Nothing Then
                GoTo Exitsub
            Else
                If Target.Value = "" Then GoTo Exitsub Else
            End If
            Application.EnableEvents = False
            Newvalue = Target.Value
            Application.Undo
            Oldvalue = Target.Value
            If Oldvalue = "" Then
                Target.Value = Newvalue
            Else
                If InStr(1, Oldvalue, Newvalue) = 0 Then
                    Target.Value = Oldvalue & ", " & Newvalue
                Else
                    Target.Value = Oldvalue
                End If
            End If
        Case Is = 7
            Set desWS = Workbooks("All Data.xlsm").Sheets(Target.Value)
            With ActiveSheet
                .ListObjects("Table1").Range.AutoFilter Field:=7, Criteria1:=Target.Value
                .AutoFilter.Range.Offset(1).Copy desWS.Cells(desWS.Rows.Count, "A").End(xlUp).Offset(1)
            End With
    End Select
    Range("A1").AutoFilter
    Application.EnableEvents = True
Exitsub:
    Application.EnableEvents = True
End Sub
 
Upvote 0
mumps said:
Replace the current Worksheet_Change macro with the one below. Make sure that both workbooks are open.
VBA Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Oldvalue As String, Newvalue As String, desWS As Worksheet
    Application.EnableEvents = True
    If Intersect(Target, Range("G:G,BK:BK,BR:BR")) Is Nothing Then Exit Sub
    On Error GoTo Exitsub
    Select Case Target.Column
        Case Is = 63, 70
            If Target.SpecialCells(xlCellTypeAllValidation) Is Nothing Then
                GoTo Exitsub
            Else
                If Target.Value = "" Then GoTo Exitsub Else
            End If
            Application.EnableEvents = False
            Newvalue = Target.Value
            Application.Undo
            Oldvalue = Target.Value
            If Oldvalue = "" Then
                Target.Value = Newvalue
            Else
                If InStr(1, Oldvalue, Newvalue) = 0 Then
                    Target.Value = Oldvalue & ", " & Newvalue
                Else
                    Target.Value = Oldvalue
                End If
            End If
        Case Is = 7
            Set desWS = Workbooks("All Data.xlsm").Sheets(Target.Value)
            With ActiveSheet
                .ListObjects("Table1").Range.AutoFilter Field:=7, Criteria1:=Target.Value
                .AutoFilter.Range.Offset(1).Copy desWS.Cells(desWS.Rows.Count, "A").End(xlUp).Offset(1)
            End With
    End Select
    Range("A1").AutoFilter
    Application.EnableEvents = True
Exitsub:
    Application.EnableEvents = True
End Sub
Click to expand...
hi
good morning and have a nice day
mumps I have tried the above coding it works fine but having a little issue
when we select the nature of emergency from drop down list in data entry file, the data only copied from column A to G ( where G contained on drop down list) the rest of data columns not copied
and there are also some columns are hidden in data entry file and have values, the values of hidden columns are also not copied
I think the code for coping row should be execute when the entry completed and mouse cursor goto next entry
if you have another idea please do something better
if you need data range, the data range is Column A to BR for each entry
thanks
 
Upvote 0
azad092 said:
hi
good morning and have a nice day
mumps I have tried the above coding it works fine but having a little issue
when we select the nature of emergency from drop down list in data entry file, the data only copied from column A to G ( where G contained on drop down list) the rest of data columns not copied
and there are also some columns are hidden in data entry file and have values, the values of hidden columns are also not copied
I think the code for coping row should be execute when the entry completed and mouse cursor goto next entry
if you have another idea please do something better
if you need data range, the data range is Column A to BR for each entry
thanks
Click to expand...
www.dropbox.com

All Data.xlsm

Shared with Dropbox
www.dropbox.com www.dropbox.com
in this updated file I have make the columns sequence same as the data entry file
 
Upvote 0
I would start by deleting the "1" in cell A2 and all the formulas in column A of all the sheets in "All Data". You don't need these as the macro copies column A from the Data Entry sheet. Then try this macro:
VBA Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Oldvalue As String, Newvalue As String, desWS As Worksheet, lastRow As Long
    With Application
        .EnableEvents = False
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
    End With
    If Intersect(Target, Range("G:G,BK:BK,BR:BR")) Is Nothing Then Exit Sub
    On Error GoTo Exitsub
    Select Case Target.Column
        Case Is = 63, 70
            If Target.SpecialCells(xlCellTypeAllValidation) Is Nothing Then
                GoTo Exitsub
            Else
                If Target.Value = "" Then GoTo Exitsub Else
            End If
            Newvalue = Target.Value
            Application.Undo
            Oldvalue = Target.Value
            If Oldvalue = "" Then
                Target.Value = Newvalue
            Else
                If InStr(1, Oldvalue, Newvalue) = 0 Then
                    Target.Value = Oldvalue & ", " & Newvalue
                Else
                    Target.Value = Oldvalue
                End If
            End If
        Case Is = 7
            Set desWS = Workbooks("All Data.xlsm").Sheets(Target.Value)
            With ActiveSheet.Columns("B").SpecialCells(xlCellTypeConstants)
                lastRow = .Cells(.Cells.Count).Row + 1
            End With
            With ActiveSheet
                .Range("A:B,H:K,N:T,AF:AF,AK:AK,AM:AV,AZ:AZ,BB:BJ,BL:BQ").EntireColumn.Hidden = False
                .ListObjects("Table1").Range.AutoFilter Field:=7, Criteria1:=Target.Value
                .AutoFilter.Range.Offset(1).Copy desWS.Cells(lastRow, 1)
                .Range("A:B,H:K,N:T,AF:AF,AK:AK,AM:AV,AZ:AZ,BB:BJ,BL:BQ").EntireColumn.Hidden = True
            End With
    End Select
    Range("A1").AutoFilter
    With Application
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
    End With
Exitsub:
    With Application
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
    End With
End Sub
End Sub
 
Last edited:
Upvote 0
I've made a slight revision. Please try:
VBA Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Oldvalue As String, Newvalue As String, desWS As Worksheet, lastRow As Long, lastRow2 As Long
    With Application
        .EnableEvents = False
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
    End With
    If Intersect(Target, Range("G:G,BK:BK,BR:BR")) Is Nothing Then Exit Sub
    On Error GoTo Exitsub
    Select Case Target.Column
        Case Is = 63, 70
            If Target.SpecialCells(xlCellTypeAllValidation) Is Nothing Then
                GoTo Exitsub
            Else
                If Target.Value = "" Then GoTo Exitsub Else
            End If
            Newvalue = Target.Value
            Application.Undo
            Oldvalue = Target.Value
            If Oldvalue = "" Then
                Target.Value = Newvalue
            Else
                If InStr(1, Oldvalue, Newvalue) = 0 Then
                    Target.Value = Oldvalue & ", " & Newvalue
                Else
                    Target.Value = Oldvalue
                End If
            End If
        Case Is = 7
            Set desWS = Workbooks("All Data.xlsm").Sheets(Target.Value)
            With ActiveSheet.Columns("B").SpecialCells(xlCellTypeConstants)
                lastRow = .Cells(.Cells.Count).Row + 1
            End With
            With ActiveSheet
                .Range("A:B,H:K,N:T,AF:AF,AK:AK,AM:AV,AZ:AZ,BB:BJ,BL:BQ").EntireColumn.Hidden = False
                .ListObjects("Table1").Range.AutoFilter Field:=7, Criteria1:=Target.Value
                lastRow2 = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
                .Range("A2:BR" & lastRow2).SpecialCells(xlCellTypeVisible).Copy desWS.Cells(lastRow, 1)
                .Range("A:B,H:K,N:T,AF:AF,AK:AK,AM:AV,AZ:AZ,BB:BJ,BL:BQ").EntireColumn.Hidden = True
            End With
    End Select
    Range("A1").AutoFilter
    With Application
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
    End With
Exitsub:
    With Application
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
    End With
End Sub
I would start by deleting the "1" in cell A2 and all the formulas in column A of all the sheets in "All Data". You don't need these as the macro copies column A from the Data Entry sheet.
 

Attachments

  • 1589646152085.png
    1589646152085.png
    339 bytes · Views: 2
  • 1589646160348.png
    1589646160348.png
    339 bytes · Views: 1
Upvote 0
I just noticed that the sheets in the All Data file have data at the very bottom of the table. You will have to delete that data in each sheet and then try this revised macro:
VBA Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Oldvalue As String, Newvalue As String, desWS As Worksheet, lastRow As Long, lastRow2 As Long
    With Application
        .EnableEvents = False
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
    End With
    If Intersect(Target, Range("G:G,BK:BK,BR:BR")) Is Nothing Then Exit Sub
    On Error GoTo Exitsub
    Select Case Target.Column
        Case Is = 63, 70
            If Target.SpecialCells(xlCellTypeAllValidation) Is Nothing Then
                GoTo Exitsub
            Else
                If Target.Value = "" Then GoTo Exitsub Else
            End If
            Newvalue = Target.Value
            Application.Undo
            Oldvalue = Target.Value
            If Oldvalue = "" Then
                Target.Value = Newvalue
            Else
                If InStr(1, Oldvalue, Newvalue) = 0 Then
                    Target.Value = Oldvalue & ", " & Newvalue
                Else
                    Target.Value = Oldvalue
                End If
            End If
        Case Is = 7
            Set desWS = Workbooks("All Data.xlsm").Sheets(Target.Value)
            lastRow = desWS.Columns("D").Find("*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows, LookIn:=xlValues).Row + 1
            With ActiveSheet
                .Range("A:B,H:K,N:T,AF:AF,AK:AK,AM:AV,AZ:AZ,BB:BJ,BL:BQ").EntireColumn.Hidden = False
                .ListObjects("Table1").Range.AutoFilter Field:=7, Criteria1:=Target.Value
                lastRow2 = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
                .Range("A2:BR" & lastRow2).SpecialCells(xlCellTypeVisible).Copy desWS.Cells(lastRow, 1)
                .Range("A:B,H:K,N:T,AF:AF,AK:AK,AM:AV,AZ:AZ,BB:BJ,BL:BQ").EntireColumn.Hidden = True
            End With
    End Select
    Range("A1").AutoFilter
    With Application
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
    End With
Exitsub:
    With Application
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
    End With
End Sub
 
Upvote 0
You must log in or register to reply here.

Similar threads

I
  • Question
VBA - Copy Sheet from a workbook saved as a date - paste to specifically named sheet in another workbook based on the date
Replies
2
Views
279
Insurance Dave
I
C
  • Question
Lookup whole rows from one sheet in another sheet?
Replies
1
Views
78
offthelip
O
A
  • Question
Copy & Paste from workbook to another with criterias
Replies
2
Views
155
Anthony86
A
D
  • Question
Copy the value of a cell onto another worksheet based on the dropdown selection
Replies
0
Views
81
denissimo
D
V
  • Question
Copy each sheet to new workbook, paste values and save to specific folder
Replies
7
Views
125
JerrExcel
JerrExcel

Forum statistics

Threads
1,215,329
Messages
6,124,302
Members
449,150
Latest member
NyDarR

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top