Copy rows to a new workbook based on conditions

DaBears

New Member
Joined
Aug 18, 2010
Messages
4
Dear All,
I've just recently started using VBA and i have a question about a current macro I have been working with. I copied this off of a former thread i found on this site and it works perfect. However now i would like to change to fit another need. I have copied in the thread from prior below but what i need changed is the column sales name to column D instead of C. The other problem I have is when column C is not letters but numbers i.e.(10,20,30,etc.) it gives me an error on the Red highlighted portion below.
Below is the former Thread with the Prior Macro. Any help showing me what I need to change when sorting on another column beside "C" would be appreciated. Also when my column C changes from letters to numbers.Thanks very much for the help in advance.

I think I need a macro to help to copy rows to a new workbook on condition after sorting
A given workbook(sales.xls) inculding a worksheet of thousands of rows and 10 columns(A...J) like as following:
---------------Sample Sheet------------------
A B C(salescode) D(amt) E(qty) F .... J
1 CA 6 CK 180 8
2 CN 5 JB 69 4
3 CN 8 MJ 30 3
4 CA 5 CK 100 7

Remark: column C is the salescode like CK which is equal to Clive_KUEN
--------------------------------------------
I would like to sort data with cloumn C first and then extract columns A,B,C,D,E to a new workbook with filename as the sales name of column C.

Here is the macro below.

Sub Run_File()
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False

Application.Run ("Add_Sheets")
Application.Run ("Find_Name_Code")

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

MsgBox "Done!"
End Sub


Private Sub Find_Name_Code()
Dim lastcol As Integer, x As Long
Dim lastrow As Long, lastrow2 As Long
Dim MyArr()
Dim DataRange As Range


With Sheets("Main")
Set DataRange = .UsedRange

lastrow = .Cells(65536, 3).End(xlUp).Row
lastcol = .Cells(1, 1).End(xlToRight).Column

.Columns(lastcol + 2).ClearContents
.Range("C1:C" & lastrow).AdvancedFilter Action:=xlFilterCopy, _
CopyToRange:=.Cells(1, lastcol + 2), Unique:=True
.Cells(1, lastcol + 2).Delete shift:=xlUp

lastrow2 = .Cells(65536, lastcol + 2).End(xlUp).Row
ReDim MyArr(1 To lastrow2)
For x = 1 To lastrow2
MyArr(x) = .Cells(x, lastcol + 2)
Next x
.Columns(lastcol + 2).ClearContents

For x = 1 To lastrow2
.Cells(1, 3).AutoFilter Field:=3, Criteria1:=MyArr(x)
DataRange.SpecialCells(xlCellTypeVisible).Copy Sheets(MyArr(x)).Range("A1")
Sheets(MyArr(x)).Copy
ThisWorkbook.Activate
Next x
.Cells(1, 3).AutoFilter
End With
End Sub


Private Sub Add_Sheets()
Dim lastrow As Long, sheettoname As String, x As Long
lastrow = Sheets("Main").Cells(Rows.Count, 3).End(xlUp).Row

For x = 2 To lastrow
sheettoname = Sheets("Main").Cells(x, 3)
If SheetExists(sheettoname) = True Then
' do nothing
Else
Worksheets.Add After:=Sheets(ThisWorkbook.Worksheets.Count)
ActiveSheet.Name = Sheets("Main").Cells(x, 3).Value
End If
Next x
Sheets("Main").Select
End Sub

Private Function NameofSheet()
NameofSheet = Application.Caller.Parent.Name
End Function

Private Function SheetExists(sheetname) As Boolean
Dim abc As Object
On Error Resume Next
Set abc = ActiveWorkbook.Sheets(sheetname)
If Err = 0 Then SheetExists = True _
Else SheetExists = False
End Function
 

Some videos you may like

Excel Facts

Last used cell?
Press Ctrl+End to move to what Excel thinks is the last used cell.

DaBears

New Member
Joined
Aug 18, 2010
Messages
4
Any help on this one would be greatly appreciated. If you need more info let me know.
 

Watch MrExcel Video

Forum statistics

Threads
1,122,372
Messages
5,595,787
Members
414,021
Latest member
whyjaydee

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
Top