Excel VBA Macro Help. Copying data from one sheet to others based on certain criteria

S

spekul8r

New Member
Joined
Feb 6, 2009
Messages
3
Hello,

I need some VBA macro help, I have been unable to figure out a good solution on my own. I currently have a workbook with 4 Sheets. Data is imported into the first sheet named Data. It contains 5000+ rows and populates data in columns A thru G. I then need to examine each row in column A and if it starts with a @ then it along with columns B thru G needs to be copied into a sheet called “Result1”, if it starts with a $ then the same thing happens but it is copied into a sheet called “Result2” and finally if it starts with anything but @ or $ it gets copied into a third sheet called “Result3”. Before this macro copies the data it also needs to clear out columns A thru G on the Results sheets but not clear them entirely because there are formulas in the columns after G.

If anyone could help me or point me in the correct direction it, I would greatly appreciate it.

Thanks,

Mike
 

Excel Facts

Show numbers in thousands?
Use a custom number format of #,##0,K. Each comma after the final 0 will divide the displayed number by another thousand
Sort by date Sort by votes
Hi Mike

This all seems to sound quite simple.
I will have a go for you if you like.
Will post back some code in bit.

Unless you want to do it yourself and do only require pointers?

Dave
 
Last edited:
Upvote 0
Give it a try on a copy or mock up first.
Code: 
Sub results()
Dim sh1 As Worksheet, sh2 As Worksheet, sh3 As Worksheet, sh4 As Worksheet, fc1 As String, fc2 As String
Set sh1 = Sheets("Data")
Set sh2 = Sheets("Results1")
Set sh3 = Sheets("Results2")
Set sh4 = Sheets("Results3")
sh2.Range("A:G").ClearContents
sh3.Range("A:G").ClearContents
sh4.Range("A:G").ClearContents
With sh1
    fc1 = "@"
    .Range("A1", .Cells(Rows.Count, 1).End(xlUp)).AutoFilter 1, fc1 & "*"
    .Range("A2", .Cells(Rows.Count, 7).End(xlUp)).SpecialCells(xlCellTypeVisible).Copy _
        sh2.Cells(Rows.Count, 1).End(xlUp)(2)
    .AutoFilterMode = False
    fc2 = "$"
    .Range("A1", .Cells(Rows.Count, 1).End(xlUp)).AutoFilter 1, fc2 & "*"
    .Range("A2", .Cells(Rows.Count, 7).End(xlUp)).SpecialCells(xlCellTypeVisible).Copy _
        sh3.Cells(Rows.Count, 1).End(xlUp)(2)
    .AutoFilterMode = False
    .Range("A1", .Cells(Rows.Count, 1).End(xlUp)).AutoFilter 1, "<>" & fc1 & "*", xlAnd, "<>" & fc2 & "*"
    .Range("A2", .Cells(Rows.Count, 7).End(xlUp)).SpecialCells(xlCellTypeVisible).Copy _
        sh4.Cells(Rows.Count, 1).End(xlUp)(2)
    .AutoFilterMode = False
End With
End Sub
 
Upvote 0
Thank you so much, that works great, it is exactly what I needed. Another quick question, if on the sheets I want to clear I want to start at row 3 so to not erase the headers how would I change the code? I tried sh2.Range("A3:G").ClearContents but I got an error message.
 
Upvote 0
Hi

There may be a better way than this, usually i do it by finding the lastrow in the column, but i thought of using a counter, but now thinking about it, if you had balnk data in column A, then this will not work.

I will post the code anyway and re-post the lastrow cod after also.

Good job JLGWhiz BTW
Code: 
Sub results()
Dim sh1 As Worksheet, sh2 As Worksheet, sh3 As Worksheet, sh4 As Worksheet, fc1 As String, fc2 As String
Set sh1 = Sheets("Data")
Set sh2 = Sheets("Results1")
Set sh3 = Sheets("Results2")
Set sh4 = Sheets("Results3")
counter1 = Application.WorksheetFunction.CountA(Range("'Results1'!a:a"))
counter2 = Application.WorksheetFunction.CountA(Range("'Results2'!a:a"))
counter3 = Application.WorksheetFunction.CountA(Range("'Results3'!a:a"))
sh2.Range("A3:G" & counter1).ClearContents
Stop
sh2.Range("A3:G" & counter2).ClearContents
sh2.Range("A3:G" & counter3).ClearContents
With sh1
    fc1 = "@"
    .Range("A1", .Cells(Rows.Count, 1).End(xlUp)).AutoFilter 1, fc1 & "*"
    .Range("A2", .Cells(Rows.Count, 7).End(xlUp)).SpecialCells(xlCellTypeVisible).Copy _
        sh2.Cells(Rows.Count, 1).End(xlUp)(2)
    .AutoFilterMode = False
    fc2 = "$"
    .Range("A1", .Cells(Rows.Count, 1).End(xlUp)).AutoFilter 1, fc2 & "*"
    .Range("A2", .Cells(Rows.Count, 7).End(xlUp)).SpecialCells(xlCellTypeVisible).Copy _
        sh3.Cells(Rows.Count, 1).End(xlUp)(2)
    .AutoFilterMode = False
    .Range("A1", .Cells(Rows.Count, 1).End(xlUp)).AutoFilter 1, "<>" & fc1 & "*", xlAnd, "<>" & fc2 & "*"
    .Range("A2", .Cells(Rows.Count, 7).End(xlUp)).SpecialCells(xlCellTypeVisible).Copy _
        sh4.Cells(Rows.Count, 1).End(xlUp)(2)
    .AutoFilterMode = False
End With
End Sub
 
Upvote 0
I believe this will be the correct/best way

dave

Code: 
Sub results()
Dim sh1 As Worksheet, sh2 As Worksheet, sh3 As Worksheet, sh4 As Worksheet, fc1 As String, fc2 As String
Dim LastRow2 As Long
Dim LastRow3 As Long
Dim LastRow4 As Long
Set sh1 = Sheets("Data")
Set sh2 = Sheets("Results1")
Set sh3 = Sheets("Results2")
Set sh4 = Sheets("Results3")
  LastRow2 = sh2.Cells(sh2.Rows.Count, "A").End(xlUp).Row
  LastRow3 = sh3.Cells(sh3.Rows.Count, "A").End(xlUp).Row
  LastRow4 = sh4.Cells(sh4.Rows.Count, "A").End(xlUp).Row
sh2.Range("A3:G" & LastRow2).ClearContents
sh3.Range("A3:G" & LastRow3).ClearContents
sh4.Range("A3:G" & LastRow4).ClearContents
With sh1
    fc1 = "@"
    .Range("A1", .Cells(Rows.Count, 1).End(xlUp)).AutoFilter 1, fc1 & "*"
    .Range("A2", .Cells(Rows.Count, 7).End(xlUp)).SpecialCells(xlCellTypeVisible).Copy _
        sh2.Cells(Rows.Count, 1).End(xlUp)(2)
    .AutoFilterMode = False
    fc2 = "$"
    .Range("A1", .Cells(Rows.Count, 1).End(xlUp)).AutoFilter 1, fc2 & "*"
    .Range("A2", .Cells(Rows.Count, 7).End(xlUp)).SpecialCells(xlCellTypeVisible).Copy _
        sh3.Cells(Rows.Count, 1).End(xlUp)(2)
    .AutoFilterMode = False
    .Range("A1", .Cells(Rows.Count, 1).End(xlUp)).AutoFilter 1, "<>" & fc1 & "*", xlAnd, "<>" & fc2 & "*"
    .Range("A2", .Cells(Rows.Count, 7).End(xlUp)).SpecialCells(xlCellTypeVisible).Copy _
        sh4.Cells(Rows.Count, 1).End(xlUp)(2)
    .AutoFilterMode = False
End With
End Sub
 
Upvote 0
spekul8r said:
Thank you so much, that works great, it is exactly what I needed. Another quick question, if on the sheets I want to clear I want to start at row 3 so to not erase the headers how would I change the code? I tried sh2.Range("A3:G").ClearContents but I got an error message.
Click to expand...

Code: 
Sub results()
Dim sh1 As Worksheet, sh2 As Worksheet, sh3 As Worksheet, sh4 As Worksheet, fc1 As String, fc2 As String
Set sh1 = Sheets("Data")
Set sh2 = Sheets("Results1")
Set sh3 = Sheets("Results2")
Set sh4 = Sheets("Results3")
sh2.Range("A3:G3").Resize(Rows.Count - 3).ClearContents
sh3.Range("A3:G3").Resize(Rows.Count - 3).ClearContents
sh4.Range("A3:G3").Resize(Rows.Count - 3).ClearContents
With sh1
    fc1 = "@"
    .Range("A1", .Cells(Rows.Count, 1).End(xlUp)).AutoFilter 1, fc1 & "*"
    .Range("A2", .Cells(Rows.Count, 7).End(xlUp)).SpecialCells(xlCellTypeVisible).Copy _
        sh2.Cells(Rows.Count, 1).End(xlUp)(2)
    .AutoFilterMode = False
    fc2 = "$"
    .Range("A1", .Cells(Rows.Count, 1).End(xlUp)).AutoFilter 1, fc2 & "*"
    .Range("A2", .Cells(Rows.Count, 7).End(xlUp)).SpecialCells(xlCellTypeVisible).Copy _
        sh3.Cells(Rows.Count, 1).End(xlUp)(2)
    .AutoFilterMode = False
    .Range("A1", .Cells(Rows.Count, 1).End(xlUp)).AutoFilter 1, "<>" & fc1 & "*", xlAnd, "<>" & fc2 & "*"
    .Range("A2", .Cells(Rows.Count, 7).End(xlUp)).SpecialCells(xlCellTypeVisible).Copy _
        sh4.Cells(Rows.Count, 1).End(xlUp)(2)
    .AutoFilterMode = False
End With
End Sub
 
Last edited:
Upvote 0
Going out of my mind and I have to believe this is simple. I have a worksheet with multiple tabs. Some of the Tabs are names "Room 1" "Room 2", etc. i am in a new tab and i want a particular cell in this new tab to show me one of the OTHER (nonactive) Tab Names. Again, to clarify I am in a Tab named NEW and in cell B12 I want the Tab named Room 2 to appear in there and change in the NEW tab if I change the name room Room 2 to Tulip

i'm sure this is so simple but i'm lost. Please help!
 
Upvote 0
You must log in or register to reply here.

Similar threads

T
  • Solved
VBA code cannot find sheet name
2
Replies
11
Views
157
jolivanes
jolivanes
Kaz09
  • Question
Copy rows of data from multiple worksheets to based on column equalling YES
Replies
0
Views
104
Kaz09
Kaz09
P
  • Question
Automating copying of columns within same sheet in excel using VBA.
Replies
1
Views
108
MountainFog
M
B
  • Solved
vba code to give next Sunday date for pasted data
Replies
2
Views
176
bh24524
B
C
  • Question
VBA Copy Sort
Replies
4
Views
128
Keebler
Keebler

Forum statistics

Threads
1,214,661
Messages
6,120,792
Members
448,994
Latest member
rohitsomani

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