how to copy rows (& auto update) to another (existing) worksheet based on criteria

G

GutzyRose

New Member
Joined
Nov 25, 2015
Messages
35
Hi All!
Here's what I'm hoping some of you wizards can help me with:

My Boss' wife has a mailing list in Excel which exceeds 500 entries. The Master list contains all the addresses. Columns 9 - 13 have designations of x, g, c, j, and p. If the person gets a mailing for Christmas, an "x" is placed in the x column. If they are part of the garden club, a "g" is placed in the g column, and so on. Each category has its own, separate worksheet (in the same workbook) to generate mail merge invitations, etc. A person can be on one or all of the mailing lists.

She regularly brings me updates. Last spring I semi-automated the address updating process by pasting a very simple "='Wellford Addresses-ALL, MASTER'!E10", etc. This process requires babysitting every time a new entry is made or one deleted, though. And further, she substantially overestimated my skills and now has me doing the mailing list for a non-profit board of which she is a member! This non-profit list has even more columns and year numbers (i.e. 13, 14, 15) are entered in the column instead of letters depending on which year the person donated, or attended or so on.

I am wading into macros for this. Since July I have been studying via Mr. Jelen's book "VBA and Macros for Microsoft Office Excel 2007" but not written any code until this month. I modified some code found on this site, but it isn't doing anything at all and I'm nearing a deadline. I am actually writing in Excel 2010 on Windows 7, but had the book from a class I took 5 years ago.

It seems like I saw a way somewhere on here to link or paste a partial spreadsheet example. If you know of a way I can do that (while changing names and contact info on sheet) please advise and I will do so. The first row contains headers. I'm trying to find a way to link active data for you to see...
Here's what I have. Apologies if it's completely off track. It does seem very long.

Rich (BB code): 
Option Explicit
Sub DisributeRowsArrays()
' CGutz November 2015
' http://www.mrexcel.com/forum/excel-...s-move-rows-another-sheet-based-criteria.html
Dim wAM As Worksheet, wX As Worksheet, wG As Worksheet, wC As Worksheet, wJ As Worksheet, wP As Worksheet
Dim am As Variant, x As Variant, g As Variant, c As Variant, j As Variant, p As Variant
Dim i As Long, lr As Long, amam As Long, xx As Long, gg As Long, cc As Long, jj As Long, pp As Long
Dim n As Long, nr As Long
Set wAM = Worksheets("Wellford Addresses-ALL, MASTER")
Set wX = Worksheets("X-Wellford Addresses")
Set wG = Worksheets("G-Wellford Addresses")
Set wC = Worksheets("C-Wellford Addresses")
Set wJ = Worksheets("J-Wellford Addresses")
Set wP = Worksheets("P-Wellford Addresses")
If wAM.FilterMode Then wAM.ShowAllData
am = wAM.Range("A1").CurrentRegion.Resize(, 13)
n = Application.CountIf(wAM.Columns(9), "x")
ReDim x(1 To n, 1 To 13)
n = Application.CountIf(wAM.Columns(10), "g")
ReDim g(1 To n, 1 To 13)
n = Application.CountIf(wAM.Columns(11), "c")
ReDim c(1 To n, 1 To 13)
n = Application.CountIf(wAM.Columns(12), "j")
ReDim j(1 To n, 1 To 13)
n = Application.CountIf(wAM.Columns(13), "p")
ReDim p(1 To n, 1 To 13)
For i = 1 To UBound(am, 1)
  If am(i, 9) = "x" Then
    xx = xx + 1
    x(xx, 1) = am(i, 1)
    x(xx, 2) = am(i, 2)
    x(xx, 3) = am(i, 3)
    x(xx, 4) = am(i, 4)
    x(xx, 5) = am(i, 5)
    x(xx, 6) = am(i, 6)
    x(xx, 7) = am(i, 7)
    x(xx, 8) = am(i, 8)
    x(xx, 9) = am(i, 9)
    x(xx, 10) = am(i, 10)
    x(xx, 11) = am(i, 11)
    x(xx, 12) = am(i, 12)
    x(xx, 13) = am(i, 13)
  ElseIf am(i, 10) = "g" Then
    gg = gg + 1
    g(gg, 1) = am(i, 1)
    g(gg, 2) = am(i, 2)
    g(gg, 3) = am(i, 3)
    g(gg, 4) = am(i, 4)
    g(gg, 5) = am(i, 5)
    g(gg, 6) = am(i, 6)
    g(gg, 7) = am(i, 7)
    g(gg, 8) = am(i, 8)
    g(gg, 9) = am(i, 9)
    g(gg, 10) = am(i, 10)
    g(gg, 11) = am(i, 11)
    g(gg, 12) = am(i, 12)
    g(gg, 13) = am(i, 13)
  ElseIf am(i, 11) = "c" Then
    cc = cc + 1
    c(cc, 1) = am(i, 1)
    c(cc, 2) = am(i, 2)
    c(cc, 3) = am(i, 3)
    c(cc, 4) = am(i, 4)
    c(cc, 5) = am(i, 5)
    c(cc, 6) = am(i, 6)
    c(cc, 7) = am(i, 7)
    c(cc, 8) = am(i, 8)
    c(cc, 9) = am(i, 9)
    c(cc, 10) = am(i, 10)
    c(cc, 11) = am(i, 11)
    c(cc, 12) = am(i, 12)
    c(cc, 13) = am(i, 13)
  ElseIf am(i, 12) = "j" Then
    jj = jj + 1
    j(jj, 1) = am(i, 1)
    j(jj, 2) = am(i, 2)
    j(jj, 3) = am(i, 3)
    j(jj, 4) = am(i, 4)
    j(jj, 5) = am(i, 5)
    j(jj, 6) = am(i, 6)
    j(jj, 7) = am(i, 7)
    j(jj, 8) = am(i, 8)
    j(jj, 9) = am(i, 9)
    j(jj, 10) = am(i, 10)
    j(jj, 11) = am(i, 11)
    j(jj, 12) = am(i, 12)
    j(jj, 13) = am(i, 13)
  ElseIf am(i, 13) = "p" Then
    pp = pp + 1
    p(pp, 1) = am(i, 1)
    p(pp, 2) = am(i, 2)
    p(pp, 3) = am(i, 3)
    p(pp, 4) = am(i, 4)
    p(pp, 5) = am(i, 5)
    p(pp, 6) = am(i, 6)
    p(pp, 7) = am(i, 7)
    p(pp, 8) = am(i, 8)
    p(pp, 9) = am(i, 9)
    p(pp, 10) = am(i, 10)
    p(pp, 11) = am(i, 11)
    p(pp, 12) = am(i, 12)
    p(pp, 13) = am(i, 13)
  End If
Next i
nr = wX.Range("A" & Rows.Count).End(xlUp).Offset(1).Row
wX.Range("A" & nr).Resize(UBound(x, 1), 13) = x
nr = wG.Range("A" & Rows.Count).End(xlUp).Offset(1).Row
wG.Range("A" & nr).Resize(UBound(g, 1), 13) = g
nr = wC.Range("A" & Rows.Count).End(xlUp).Offset(1).Row
wC.Range("A" & nr).Resize(UBound(c, 1), 13) = c
nr = wJ.Range("A" & Rows.Count).End(xlUp).Offset(1).Row
wJ.Range("A" & nr).Resize(UBound(j, 1), 13) = j
nr = wP.Range("A" & Rows.Count).End(xlUp).Offset(1).Row
wP.Range("A" & nr).Resize(UBound(p, 1), 13) = p
If wAM.FilterMode Then wAM.ShowAllData
End Sub
 
Last edited by a moderator:
Sort by date Sort by votes

Excel Facts

Which lookup functions find a value equal or greater than the lookup value?
MATCH uses -1 to find larger value (lookup table must be sorted ZA). XLOOKUP uses 1 to find values greater and does not need to be sorted.
Thank you! Tied up on a legal call but 1st thing in morning I should be able to review and (hopefully) apply myself to this more.
Christine
 
Upvote 0
Give this a try.

https://www.dropbox.com/s/437zqlw9pb0lmbf/Wellford Non Profit Test Book Drop Box.xlsm?dl=0

This is a new workbook version of the example you posted. That version was 13.MB, and sluggish and froze up on me a few times.

The new version is about 250KB and seems to be much more nimble. There is no color formatting on the new, you may do as you like with that.

To operate the sheet, on !AL CP! in the A1 cell area, note a small blue shape icon. The macro is run with a click on the blue shape.

So, you will enter the values in the N to W columns (and the value can also be a text value, X, MM, OK etc. or a number as you have been using).

Then click the blue run icon. Check the sheet result closely for accuracy. I filled two column for two copy to sheets, 800+ rows X 2 to be copied to two different sheets, time was about 8 seconds on my computer.

Test away.

Also note on !AL CP! in cell X1 area is a little red filled icon. Use this to clear the codes in the N to W columns. Just click the icon, follow the prompts.

Each copy-to sheet has a similar clear icon in the A1 cell area. Click and follow the prompts.

Test and let me know of what adjustments you need.

Here is the codes.


For the !AL CP! sheet copy operation.

Code: 
Option Explicit

Sub Copy_Non_Profit()
'/by Claus @ MSPublic

Dim LRow As Long, n As Long, m As Long
Dim varCheck As Variant, varData As Variant

Application.ScreenUpdating = False

With Sheets("!ALL CP!")
    LRow = .Cells(Rows.Count, 4).End(xlUp).Row
    
    varCheck = .Range("N2:W" & LRow)
    varData = .Range("D2:W" & LRow)
    
    For n = LBound(varCheck) To UBound(varCheck)
    
        For m = LBound(varCheck, 2) To UBound(varCheck, 2)
        
            If Len(varCheck(n, m)) > 0 Then
        
                Sheets(.Cells(1, m + 13).Value).Cells(Rows.Count, 4) _
                    .End(xlUp)(2).Resize(1, 20).Value = Application.Index(varData, n, 0)
            End If
            
        Next m
        
    Next n
    
End With

For n = 3 To Sheets.Count
    Sheets(n).UsedRange.WrapText = False
    Sheets(n).Columns("A:W").AutoFit
Next

Application.ScreenUpdating = True
End Sub



For the clear !AL CP! column N to W codes.

Code: 
Sub Clear_ALL_CP_Sheet()
  '/ For !ALL_CP! sheet only
  
  Dim FirstCell As Range, LastCell As Range
  Dim msg, ans, Cancel
  Dim wks As String
 
  
  Set LastCell = Cells(Cells.Find(What:="*", SearchOrder:=xlRows, _
      SearchDirection:=xlPrevious, LookIn:=xlValues).Row, _
      Cells.Find(What:="*", SearchOrder:=xlByColumns, _
      SearchDirection:=xlPrevious, LookIn:=xlValues).Column)
  Set FirstCell = Cells(2, 14)
  
         
        msg = "Do you want to clear all the CODE entries" & _
                  vbCr & "              in this worksheet? " & _
                  vbCr & vbCr & "                     " & ActiveSheet.Name

        
        ans = MsgBox(msg, vbQuestion + vbYesNoCancel)
        
        Select Case ans
            Case vbYes
                    'Range(FirstCell, LastCell).Select
                Range(FirstCell, LastCell).ClearContents
                MsgBox "Codes are cleared!"
                [D2].Activate
            Case vbNo
                MsgBox "You selected ""No"", good bye."
                [D2].Activate
                Exit Sub
            Case vbCancel
                'MsgBox "Cancel was clicked"
                Cancel = True
                Exit Sub
        End Select
  
End Sub



And clear code for the copy-to sheets.

Code: 
Sub ClearThisSheetOnly()
   '/ For these sheets PTY SP, PTY DN, PTY IVT, PTY AT, FN DN, _
                       FCP IVT, FCP M, FCP SP, DAME, PUBLIC

  Dim FirstCell As Range, LastCell As Range
  Dim msg, ans, Cancel
  Dim wks As String
 
  
  Set LastCell = Cells(Cells.Find(What:="*", SearchOrder:=xlRows, _
      SearchDirection:=xlPrevious, LookIn:=xlValues).Row, _
      Cells.Find(What:="*", SearchOrder:=xlByColumns, _
      SearchDirection:=xlPrevious, LookIn:=xlValues).Column)
  Set FirstCell = Cells(2, 1)
  
         
        msg = "Do you want to clear entries," & _
                  vbCr & "        in this worksheet " & _
                  vbCr & vbCr & "               " & ActiveSheet.Name

        
        ans = MsgBox(msg, vbQuestion + vbYesNoCancel)
        
        Select Case ans
            Case vbYes
                'Range(FirstCell, LastCell).Select
                Range(FirstCell, LastCell).ClearContents
                MsgBox "Sheet cleared!"
                [D2].Activate
            Case vbNo
                MsgBox "You selected ""No"", good bye."
                [D2].Activate
                Exit Sub
            Case vbCancel
                'MsgBox "Cancel was clicked"
                Cancel = True
                Exit Sub
          End Select
  
End Sub
 
Upvote 0
Wow! You've been busy!
I'll plug all this in this morning. And unless Boss John diverts me, I should be able to get back to you by this afternoon.
Back soon (-:
 
Upvote 0
"This morning" turned into this afternoon, lol. I finally was able to run it and it worked beautifully! And I don't know who claus is at mspublic, but I'm calling him Santa.
You? I still owe you a martini or two or something. (y)
It will be so exceptionally fantastic to put in all the columns plus some finishing touches and be done, at least with the non-profit. I think I can take it from here.
Howard Howard Howard, Thank You :) Thank You :) Thank You :) !
Your help has been immeasurable!


Christine
 
Upvote 0
Hi Christine,

You are very welcome, glad it works well for you.

Here is a "Bud-Lite" version of the other workbook you first mentioned in this thread.

https://www.dropbox.com/s/jeksa0sp2pfivr2/Wellford Tester ver 2 Drop Box.xlsm?dl=0

It has a three row name/info bloc. In the EMAIL column is the actual row number from top row 2, to bottom of info rows, 112. That can help verify the correct info is being moved properly during tests.

Click the blue STAR in the N1 cell, check results.

There are no clear codes. You can use the other workbook clear codes as an example on this workbook if needed. If you need help setting the "clears" up, post back.

Howard


The code.

Code: 
Option Explicit

Sub Copy_ALL_MASTER()
Dim LRow As Long, n As Long, m As Long
Dim varCheck As Variant

Const shName = "-Wellford Addresses"

With Sheets("Wellford Addresses-ALL, MASTER")

    LRow = .Cells(Rows.Count, 1).End(xlUp).Row
    varCheck = .Range("I2:M" & LRow)
    
    For n = LBound(varCheck) To UBound(varCheck)
    
        For m = LBound(varCheck, 2) To UBound(varCheck, 2)
        
            If Len(varCheck(n, m)) > 0 Then
               If Sheets(UCase(varCheck(n, m)) & shName).Cells(2, 1) <> "" Then
               
                Sheets(UCase(varCheck(n, m)) & shName).Cells(Rows.Count, 1) _
                    .End(xlUp)(5).Resize(3, 8).Value = .Cells(n + 1, 1).Resize(3, 8).Value
                    
               Else
                Sheets(UCase(varCheck(n, m)) & shName).Cells(Rows.Count, 1) _
                    .End(xlUp)(2).Resize(3, 8) = .Cells(n + 1, 1).Resize(3, 8).Value
               End If
               
            End If
            
        Next m
        
    Next n
    
End With
 
Upvote 0
Hi Howard,
We're not done yet )-:
I've been plugging the code into my non-profit sheet. It runs well. But The Blue Box to run the macro does not appear, nor do the icons to clear the data.
Otherwise plugging away at it...
Christine
 
Upvote 0
Hi Christine,

Purely a user choice, for a quick "erase-the-board-and-start-afresh". There are data over a large area and if needed, it can all go away with a button click.

Otherwise, none.

Howard
 
Upvote 0
Hi Howard,
Setting up the sheet, I'm finding when the "instant erase" button might come in handy, lol.
For now though, the buttons do need to appear. Not sure why they aren't.
Christine
 
Upvote 0
You must log in or register to reply here.

Similar threads

K
  • Solved
Update to existing Move data macro
2
Replies
11
Views
413
Alex Blakenburg
A
K
  • Question
conditional formatting question
Replies
2
Views
222
kerm007
K
P
  • Question
Data not copying fully into ListBox2
Replies
0
Views
158
Patriot2879
P
K
  • Solved
Previously working very complex VBA now stopped
Replies
7
Views
203
Alex Blakenburg
A
B
  • Question
Matching Multiple Header Row Cell Values - Copy the data below to next available row.
Replies
2
Views
294
B-radK
B

Forum statistics

Threads
1,215,943
Messages
6,127,820
Members
449,409
Latest member
katiecolorado

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