VBA help

I

Isabella

Well-known Member
Joined
Nov 7, 2008
Messages
643
Hi All, i have a work task which i perform every month which i need automating. I have 3 worksheets at present (RawData, SMPJPD15, SMPUB915). From the raw data i will copy data for each unique security (Col B) to its own worksheet and then insert row between each unique portfolio. See below examples:

Ranges are correct as shown in the examples.

Excel Workbook
ABCDEFGHIJK
4PfCodeSecurity Short NameReportGroupCategory&SubtypeIDNumberTransShortNameBrokerCodeContractDateSettlementDate TransUnits
5RSTAHYSMPJPD15SMP JP 061215 CC 85DS04157957DS-PURJPMAUD22/12/201022/12/2010-3,500,000.00
6RSTAHYSMPJPD15SMP JP 061215 CC 85DS04158305DS-PURJPMAUD23/12/201023/12/2010-440,000.00
7RSTBFASMPJPD15SMP JP 061215 CC 85DS04157959DS-PURJPMAUD22/12/201022/12/2010-3,150,000.00
8RSTBFASMPJPD15SMP JP 061215 CC 85DS04158304DS-PURJPMAUD23/12/201023/12/2010-480,000.00
9RTFDBGSMPJPD15SMP JP 061215 CC 85DS04157958DS-PURJPMAUD22/12/201022/12/2010-770,000.00
10RTFDBGSMPJPD15SMP JP 061215 CC 85DS04160168DS-PURJPMSYD30/12/201030/12/2010-280,000.00
11RTFDBGSMPJPD15SMP JP 061215 CC 85DS04160457INT INT 31/12/201031/12/20100.00
12RTEYFGSMPUB915SMP UBS 092015 CC 85DS04150708DS-PURUBSAUD3/12/20103/12/2010-380,000.00
13RTEYFGSMPUB915SMP UBS 092015 CC 85DS04151121DS-PURUBSAUD6/12/20106/12/2010-440,000.00
14RTEYFGSMPUB915SMP UBS 092015 CC 85DS04152649DS-PURUBSAUD8/12/20108/12/2010-520,000.00
15RTFDBGSMPUB915SMP UBS 092015 CC 85DS04154816DS-PURUBSAUD14/12/201014/12/2010-260,000.00
16RTFDBGSMPUB915SMP UBS 092015 CC 85DS04155882DS-PURUBSAUD16/12/201016/12/2010-570,000.00
17RTFDBGSMPUB915SMP UBS 092015 CC 85DS04158291DS-PURUBSAUD23/12/201023/12/2010-490,000.00
18RTFDBGSMPUB915SMP UBS 092015 CC 85DS04159263DS-PURUBSAUD29/12/201029/12/2010-520,000.00
19RSTBFASMPUB915SMP UBS 092015 CC 85DS04160460INT INT 31/12/201031/12/20100.00
20RSTBFASMPUB915SMP UBS 092015 CC 85DS04160656DS-PURUBSAUD31/12/201031/12/2010-320,000.00
RawData



Excel Workbook
ABCDEFGHI
5PfCodeSecurityShort NameIDNumberTransShortNameBrokerCodeContract DateSettlementDateTrans Units
6RSTAHYSMPJPD15SMP JP 061215 CC 157957DS-PURJPMAUD22/12/201022/12/2010-3,500,000.00
7RSTAHYSMPJPD15SMP JP 061215 CC 158305DS-PURJPMAUD23/12/201023/12/2010-440,000.00
8
9RSTBFASMPJPD15SMP JP 061215 CC 157959DS-PURJPMAUD22/12/201022/12/2010-3,150,000.00
10RSTBFASMPJPD15SMP JP 061215 CC 158304DS-PURJPMAUD23/12/201023/12/2010-480,000.00
11
12RTFDBGSMPJPD15SMP JP 061215 CC 157958DS-PURJPMAUD22/12/201022/12/2010-770,000.00
13RTFDBGSMPJPD15SMP JP 061215 CC 160168DS-PURJPMSYD30/12/201030/12/2010-280,000.00
14RTFDBGSMPJPD15SMP JP 061215 CC 160457INT INT 31/12/201031/12/20100.00
15
16
SMPJPD15


Excel Workbook
ABCDEFGHI
5PfCodeSecurityShort NameIDNumberTransShortNameBrokerCodeContract DateSettlementDateTrans Units
6RTEYFGSMPUB915SMP UBS 092015 CC 150708DS-PURUBSAUD3/12/20103/12/2010-380,000.00
7RTEYFGSMPUB915SMP UBS 092015 CC 151121DS-PURUBSAUD6/12/20106/12/2010-440,000.00
8RTEYFGSMPUB915SMP UBS 092015 CC 152649DS-PURUBSAUD8/12/20108/12/2010-520,000.00
9
10RTFDBGSMPUB915SMP UBS 092015 CC 154816DS-PURUBSAUD14/12/201014/12/2010-260,000.00
11RTFDBGSMPUB915SMP UBS 092015 CC 155882DS-PURUBSAUD16/12/201016/12/2010-570,000.00
12RTFDBGSMPUB915SMP UBS 092015 CC 158291DS-PURUBSAUD23/12/201023/12/2010-490,000.00
13RTFDBGSMPUB915SMP UBS 092015 CC 159263DS-PURUBSAUD29/12/201029/12/2010-520,000.00
14
15RSTBFASMPUB915SMP UBS 092015 CC 160460INT INT 31/12/201031/12/20100.00
16RSTBFASMPUB915SMP UBS 092015 CC 160656DS-PURUBSAUD31/12/201031/12/2010-320,000.00
17
18
19
SMPUB915
 

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.
Sort by date Sort by votes
Isabella,


Sample raw data:


Excel Workbook
ABCDEFGHIJK
4PfCodeSecurity* * * * * Short NameReportGroupCategory&SubtypeIDNumberTransShortNameBrokerCode*ContractDate*SettlementDate* * * *TransUnits
5RSTAHYSMPJPD15SMP JP 061215 CC * *85DS04157957DS-PURJPMAUD22/12/201022/12/2010-3,500,000.00
6RSTAHYSMPJPD15SMP JP 061215 CC * *85DS04158305DS-PURJPMAUD23/12/201023/12/2010-440,000.00
7RSTBFASMPJPD15SMP JP 061215 CC * *85DS04157959DS-PURJPMAUD22/12/201022/12/2010-3,150,000.00
8RSTBFASMPJPD15SMP JP 061215 CC * *85DS04158304DS-PURJPMAUD23/12/201023/12/2010-480,000.00
9RTFDBGSMPJPD15SMP JP 061215 CC * *85DS04157958DS-PURJPMAUD22/12/201022/12/2010-770,000.00
10RTFDBGSMPJPD15SMP JP 061215 CC * *85DS04160168DS-PURJPMSYD30/12/201030/12/2010-280,000.00
11RTFDBGSMPJPD15SMP JP 061215 CC * *85DS04160457INT *INT *31/12/201031/12/20100.00
12RTEYFGSMPUB915SMP UBS 092015 CC *85DS04150708DS-PURUBSAUD3/12/20103/12/2010-380,000.00
13RTEYFGSMPUB915SMP UBS 092015 CC *85DS04151121DS-PURUBSAUD6/12/20106/12/2010-440,000.00
14RTEYFGSMPUB915SMP UBS 092015 CC *85DS04152649DS-PURUBSAUD8/12/20108/12/2010-520,000.00
15RTFDBGSMPUB915SMP UBS 092015 CC *85DS04154816DS-PURUBSAUD14/12/201014/12/2010-260,000.00
16RTFDBGSMPUB915SMP UBS 092015 CC *85DS04155882DS-PURUBSAUD16/12/201016/12/2010-570,000.00
17RTFDBGSMPUB915SMP UBS 092015 CC *85DS04158291DS-PURUBSAUD23/12/201023/12/2010-490,000.00
18RTFDBGSMPUB915SMP UBS 092015 CC *85DS04159263DS-PURUBSAUD29/12/201029/12/2010-520,000.00
19RSTBFASMPUB915SMP UBS 092015 CC *85DS04160460INT *INT *31/12/201031/12/20100.00
20RSTBFASMPUB915SMP UBS 092015 CC *85DS04160656DS-PURUBSAUD31/12/201031/12/2010-320,000.00
21
RawData





After the macro:


Excel Workbook
ABCDEFGHIJK
5PfCodeSecurity* * * * * Short NameReportGroupCategory&SubtypeIDNumberTransShortNameBrokerCode*ContractDate*SettlementDate* * * *TransUnits
6RSTAHYSMPJPD15SMP JP 061215 CC * *85DS04157957DS-PURJPMAUD22/12/201022/12/2010-3,500,000.00
7RSTAHYSMPJPD15SMP JP 061215 CC * *85DS04158305DS-PURJPMAUD23/12/201023/12/2010-440,000.00
8
9RSTBFASMPJPD15SMP JP 061215 CC * *85DS04157959DS-PURJPMAUD22/12/201022/12/2010-3,150,000.00
10RSTBFASMPJPD15SMP JP 061215 CC * *85DS04158304DS-PURJPMAUD23/12/201023/12/2010-480,000.00
11
12RTFDBGSMPJPD15SMP JP 061215 CC * *85DS04157958DS-PURJPMAUD22/12/201022/12/2010-770,000.00
13RTFDBGSMPJPD15SMP JP 061215 CC * *85DS04160168DS-PURJPMSYD30/12/201030/12/2010-280,000.00
14RTFDBGSMPJPD15SMP JP 061215 CC * *85DS04160457INT *INT *31/12/201031/12/20100.00
15
SMPJPD15





Excel Workbook
ABCDEFGHIJK
5PfCodeSecurity* * * * * Short NameReportGroupCategory&SubtypeIDNumberTransShortNameBrokerCode*ContractDate*SettlementDate* * * *TransUnits
6RTEYFGSMPUB915SMP UBS 092015 CC *85DS04150708DS-PURUBSAUD3/12/20103/12/2010-380,000.00
7RTEYFGSMPUB915SMP UBS 092015 CC *85DS04151121DS-PURUBSAUD6/12/20106/12/2010-440,000.00
8RTEYFGSMPUB915SMP UBS 092015 CC *85DS04152649DS-PURUBSAUD8/12/20108/12/2010-520,000.00
9
10RTFDBGSMPUB915SMP UBS 092015 CC *85DS04154816DS-PURUBSAUD14/12/201014/12/2010-260,000.00
11RTFDBGSMPUB915SMP UBS 092015 CC *85DS04155882DS-PURUBSAUD16/12/201016/12/2010-570,000.00
12RTFDBGSMPUB915SMP UBS 092015 CC *85DS04158291DS-PURUBSAUD23/12/201023/12/2010-490,000.00
13RTFDBGSMPUB915SMP UBS 092015 CC *85DS04159263DS-PURUBSAUD29/12/201029/12/2010-520,000.00
14
15RSTBFASMPUB915SMP UBS 092015 CC *85DS04160460INT *INT *31/12/201031/12/20100.00
16RSTBFASMPUB915SMP UBS 092015 CC *85DS04160656DS-PURUBSAUD31/12/201031/12/2010-320,000.00
17
SMPUB915





Please TEST this FIRST in a COPY of your workbook (always make a backup copy before trying new code, you never know what you might lose).


1. Copy the below code, by highlighting the code and pressing the keys CTRL + C
2. Open your workbook
3. Press the keys ALT + F11 to open the Visual Basic Editor
4. Press the keys ALT + I to activate the Insert menu
5. Press M to insert a Standard Module
6. Where the cursor is flashing, paste the code by pressing the keys CTRL + V
7. Press the keys ALT + Q to exit the Editor, and return to Excel
8. To run the macro from Excel, open the workbook, and press ALT + F8 to display the Run Macro Dialog. Double Click the macro's name to Run it.


Code: 
Option Explicit
Sub DistributeRows()
' hiker95, 03/04/2011
' http://www.mrexcel.com/forum/showthread.php?t=533700
' Original code by Norie
' http://www.mrexcel.com/forum/showthread.php?t=315083
Dim wsAll As Worksheet, wsCrit As Worksheet, wsNew As Worksheet
Dim LastRow As Long, LR As Long, a As Long, LastRowCrit As Long, I As Long
Application.ScreenUpdating = False
Set wsAll = Worksheets("RawData")
LastRow = wsAll.Range("B" & Rows.Count).End(xlUp).Row
Set wsCrit = Worksheets.Add
wsAll.Range("B4:B" & LastRow).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=wsCrit.Range("A1"), Unique:=True
LastRowCrit = wsCrit.Range("A" & Rows.Count).End(xlUp).Row
For I = 2 To LastRowCrit
  Set wsNew = Worksheets.Add(After:=Worksheets(Worksheets.Count))
  wsNew.Name = wsCrit.Range("A2")
  wsAll.Rows("1:" & LastRow).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=wsCrit.Range("A1:A2"), CopyToRange:=wsNew.Range("A1"), Unique:=False
  wsNew.UsedRange.Columns.AutoFit
  LR = wsNew.Cells(Rows.Count, 1).End(xlUp).Row
  For a = LR To 3 Step -1
    If wsNew.Cells(a, 1) <> wsNew.Cells(a - 1, 1) Then
      wsNew.Rows(a).Insert
    End If
  Next a
  wsNew.Rows(1).Resize(4).Insert
  wsCrit.Rows(2).Delete
Next I
Application.DisplayAlerts = False
wsCrit.Delete
Application.DisplayAlerts = True
wsAll.Activate
Application.ScreenUpdating = True
End Sub



Then run the DistributeRows macro.
 
Upvote 0
Paste this into a module and run 'Test' on the 'RawData' sheet;
Code: 
Sub Test()
Application.ScreenUpdating = False
Worksheets.Add.Name = "SMPJPD15"
Worksheets.Add.Name = "SMPUB915"
Sheets("RawData").Activate
For N = 2 To Cells(Rows.Count, 8).End(xlUp).Row
    If Cells(N, 3) = "SMPJPD15" Then
        Rows(N).Copy Destination:=Sheets("SMPJPD15").Cells(Rows.Count, 3).End(xlUp).Offset(1, 0).EntireRow
    End If
Next N
Sheets("SMPJPD15").Select
Call InsBl

Sheets("RawData").Activate
For N = 2 To Cells(Rows.Count, 8).End(xlUp).Row
    If Cells(N, 3) = "SMPUB915" Then
        Rows(N).Copy Destination:=Sheets("SMPUB915").Cells(Rows.Count, 3).End(xlUp).Offset(1, 0).EntireRow
    End If
Next N
Sheets("SMPUB915").Select
Call InsBl
Sheets("RawData").Activate
Application.ScreenUpdating = True
End Sub

Sub InsBl()
Dim LR As Long, i As Long
LR = Range("B" & Rows.Count).End(xlUp).Row
For i = LR To 2 Step -1
    If Range("B" & i).Value <> Range("B" & i - 1).Value Then Rows(i).Insert
Next i
End Sub

Bits of this code have been adapted from contributors of this board,
hth
Colin
 
Upvote 0
Hi,

I dont require the code to add worksheets the worksheets are already set.

hiker95 said:
Isabella,


Sample raw data:


Excel Workbook
ABCDEFGHIJK
4PfCodeSecurity* * * * * Short NameReportGroupCategory&SubtypeIDNumberTransShortNameBrokerCode*ContractDate*SettlementDate* * * *TransUnits
5RSTAHYSMPJPD15SMP JP 061215 CC * *85DS04157957DS-PURJPMAUD22/12/201022/12/2010-3,500,000.00
6RSTAHYSMPJPD15SMP JP 061215 CC * *85DS04158305DS-PURJPMAUD23/12/201023/12/2010-440,000.00
7RSTBFASMPJPD15SMP JP 061215 CC * *85DS04157959DS-PURJPMAUD22/12/201022/12/2010-3,150,000.00
8RSTBFASMPJPD15SMP JP 061215 CC * *85DS04158304DS-PURJPMAUD23/12/201023/12/2010-480,000.00
9RTFDBGSMPJPD15SMP JP 061215 CC * *85DS04157958DS-PURJPMAUD22/12/201022/12/2010-770,000.00
10RTFDBGSMPJPD15SMP JP 061215 CC * *85DS04160168DS-PURJPMSYD30/12/201030/12/2010-280,000.00
11RTFDBGSMPJPD15SMP JP 061215 CC * *85DS04160457INT *INT *31/12/201031/12/20100.00
12RTEYFGSMPUB915SMP UBS 092015 CC *85DS04150708DS-PURUBSAUD3/12/20103/12/2010-380,000.00
13RTEYFGSMPUB915SMP UBS 092015 CC *85DS04151121DS-PURUBSAUD6/12/20106/12/2010-440,000.00
14RTEYFGSMPUB915SMP UBS 092015 CC *85DS04152649DS-PURUBSAUD8/12/20108/12/2010-520,000.00
15RTFDBGSMPUB915SMP UBS 092015 CC *85DS04154816DS-PURUBSAUD14/12/201014/12/2010-260,000.00
16RTFDBGSMPUB915SMP UBS 092015 CC *85DS04155882DS-PURUBSAUD16/12/201016/12/2010-570,000.00
17RTFDBGSMPUB915SMP UBS 092015 CC *85DS04158291DS-PURUBSAUD23/12/201023/12/2010-490,000.00
18RTFDBGSMPUB915SMP UBS 092015 CC *85DS04159263DS-PURUBSAUD29/12/201029/12/2010-520,000.00
19RSTBFASMPUB915SMP UBS 092015 CC *85DS04160460INT *INT *31/12/201031/12/20100.00
20RSTBFASMPUB915SMP UBS 092015 CC *85DS04160656DS-PURUBSAUD31/12/201031/12/2010-320,000.00
21
RawData





After the macro:


Excel Workbook
ABCDEFGHIJK
5PfCodeSecurity* * * * * Short NameReportGroupCategory&SubtypeIDNumberTransShortNameBrokerCode*ContractDate*SettlementDate* * * *TransUnits
6RSTAHYSMPJPD15SMP JP 061215 CC * *85DS04157957DS-PURJPMAUD22/12/201022/12/2010-3,500,000.00
7RSTAHYSMPJPD15SMP JP 061215 CC * *85DS04158305DS-PURJPMAUD23/12/201023/12/2010-440,000.00
8
9RSTBFASMPJPD15SMP JP 061215 CC * *85DS04157959DS-PURJPMAUD22/12/201022/12/2010-3,150,000.00
10RSTBFASMPJPD15SMP JP 061215 CC * *85DS04158304DS-PURJPMAUD23/12/201023/12/2010-480,000.00
11
12RTFDBGSMPJPD15SMP JP 061215 CC * *85DS04157958DS-PURJPMAUD22/12/201022/12/2010-770,000.00
13RTFDBGSMPJPD15SMP JP 061215 CC * *85DS04160168DS-PURJPMSYD30/12/201030/12/2010-280,000.00
14RTFDBGSMPJPD15SMP JP 061215 CC * *85DS04160457INT *INT *31/12/201031/12/20100.00
15
SMPJPD15





Excel Workbook
ABCDEFGHIJK
5PfCodeSecurity* * * * * Short NameReportGroupCategory&SubtypeIDNumberTransShortNameBrokerCode*ContractDate*SettlementDate* * * *TransUnits
6RTEYFGSMPUB915SMP UBS 092015 CC *85DS04150708DS-PURUBSAUD3/12/20103/12/2010-380,000.00
7RTEYFGSMPUB915SMP UBS 092015 CC *85DS04151121DS-PURUBSAUD6/12/20106/12/2010-440,000.00
8RTEYFGSMPUB915SMP UBS 092015 CC *85DS04152649DS-PURUBSAUD8/12/20108/12/2010-520,000.00
9
10RTFDBGSMPUB915SMP UBS 092015 CC *85DS04154816DS-PURUBSAUD14/12/201014/12/2010-260,000.00
11RTFDBGSMPUB915SMP UBS 092015 CC *85DS04155882DS-PURUBSAUD16/12/201016/12/2010-570,000.00
12RTFDBGSMPUB915SMP UBS 092015 CC *85DS04158291DS-PURUBSAUD23/12/201023/12/2010-490,000.00
13RTFDBGSMPUB915SMP UBS 092015 CC *85DS04159263DS-PURUBSAUD29/12/201029/12/2010-520,000.00
14
15RSTBFASMPUB915SMP UBS 092015 CC *85DS04160460INT *INT *31/12/201031/12/20100.00
16RSTBFASMPUB915SMP UBS 092015 CC *85DS04160656DS-PURUBSAUD31/12/201031/12/2010-320,000.00
17
SMPUB915





Please TEST this FIRST in a COPY of your workbook (always make a backup copy before trying new code, you never know what you might lose).


1. Copy the below code, by highlighting the code and pressing the keys CTRL + C
2. Open your workbook
3. Press the keys ALT + F11 to open the Visual Basic Editor
4. Press the keys ALT + I to activate the Insert menu
5. Press M to insert a Standard Module
6. Where the cursor is flashing, paste the code by pressing the keys CTRL + V
7. Press the keys ALT + Q to exit the Editor, and return to Excel
8. To run the macro from Excel, open the workbook, and press ALT + F8 to display the Run Macro Dialog. Double Click the macro's name to Run it.


Code: 
Option Explicit
Sub DistributeRows()
' hiker95, 03/04/2011
' http://www.mrexcel.com/forum/showthread.php?t=533700
' Original code by Norie
' http://www.mrexcel.com/forum/showthread.php?t=315083
Dim wsAll As Worksheet, wsCrit As Worksheet, wsNew As Worksheet
Dim LastRow As Long, LR As Long, a As Long, LastRowCrit As Long, I As Long
Application.ScreenUpdating = False
Set wsAll = Worksheets("RawData")
LastRow = wsAll.Range("B" & Rows.Count).End(xlUp).Row
Set wsCrit = Worksheets.Add
wsAll.Range("B4:B" & LastRow).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=wsCrit.Range("A1"), Unique:=True
LastRowCrit = wsCrit.Range("A" & Rows.Count).End(xlUp).Row
For I = 2 To LastRowCrit
  Set wsNew = Worksheets.Add(After:=Worksheets(Worksheets.Count))
  wsNew.Name = wsCrit.Range("A2")
  wsAll.Rows("1:" & LastRow).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=wsCrit.Range("A1:A2"), CopyToRange:=wsNew.Range("A1"), Unique:=False
  wsNew.UsedRange.Columns.AutoFit
  LR = wsNew.Cells(Rows.Count, 1).End(xlUp).Row
  For a = LR To 3 Step -1
    If wsNew.Cells(a, 1) <> wsNew.Cells(a - 1, 1) Then
      wsNew.Rows(a).Insert
    End If
  Next a
  wsNew.Rows(1).Resize(4).Insert
  wsCrit.Rows(2).Delete
Next I
Application.DisplayAlerts = False
wsCrit.Delete
Application.DisplayAlerts = True
wsAll.Activate
Application.ScreenUpdating = True
End Sub

Then run the DistributeRows macro.
Click to expand...
 
Upvote 0
When i run the code nothing happens, what ranges have you used? Also i dont require the code to add sheets, sheets are already there.

rs2k said:
Paste this into a module and run 'Test' on the 'RawData' sheet;
Code: 
Sub Test()
Application.ScreenUpdating = False
Worksheets.Add.Name = "SMPJPD15"
Worksheets.Add.Name = "SMPUB915"
Sheets("RawData").Activate
For N = 2 To Cells(Rows.Count, 8).End(xlUp).Row
    If Cells(N, 3) = "SMPJPD15" Then
        Rows(N).Copy Destination:=Sheets("SMPJPD15").Cells(Rows.Count, 3).End(xlUp).Offset(1, 0).EntireRow
    End If
Next N
Sheets("SMPJPD15").Select
Call InsBl

Sheets("RawData").Activate
For N = 2 To Cells(Rows.Count, 8).End(xlUp).Row
    If Cells(N, 3) = "SMPUB915" Then
        Rows(N).Copy Destination:=Sheets("SMPUB915").Cells(Rows.Count, 3).End(xlUp).Offset(1, 0).EntireRow
    End If
Next N
Sheets("SMPUB915").Select
Call InsBl
Sheets("RawData").Activate
Application.ScreenUpdating = True
End Sub

Sub InsBl()
Dim LR As Long, i As Long
LR = Range("B" & Rows.Count).End(xlUp).Row
For i = LR To 2 Step -1
    If Range("B" & i).Value <> Range("B" & i - 1).Value Then Rows(i).Insert
Next i
End Sub
Bits of this code have been adapted from contributors of this board,
hth
Colin
Click to expand...
 
Upvote 0
Ok, i played with the ranges and manged to get the code to work, but how do i get the code to paste the data as Values, and i only want to show the columns as shown in my result sheets in #1

rs2k said:
Paste this into a module and run 'Test' on the 'RawData' sheet;
Code: 
Sub Test()
Application.ScreenUpdating = False
Worksheets.Add.Name = "SMPJPD15"
Worksheets.Add.Name = "SMPUB915"
Sheets("RawData").Activate
For N = 2 To Cells(Rows.Count, 8).End(xlUp).Row
    If Cells(N, 3) = "SMPJPD15" Then
        Rows(N).Copy Destination:=Sheets("SMPJPD15").Cells(Rows.Count, 3).End(xlUp).Offset(1, 0).EntireRow
    End If
Next N
Sheets("SMPJPD15").Select
Call InsBl

Sheets("RawData").Activate
For N = 2 To Cells(Rows.Count, 8).End(xlUp).Row
    If Cells(N, 3) = "SMPUB915" Then
        Rows(N).Copy Destination:=Sheets("SMPUB915").Cells(Rows.Count, 3).End(xlUp).Offset(1, 0).EntireRow
    End If
Next N
Sheets("SMPUB915").Select
Call InsBl
Sheets("RawData").Activate
Application.ScreenUpdating = True
End Sub

Sub InsBl()
Dim LR As Long, i As Long
LR = Range("B" & Rows.Count).End(xlUp).Row
For i = LR To 2 Step -1
    If Range("B" & i).Value <> Range("B" & i - 1).Value Then Rows(i).Insert
Next i
End Sub
Bits of this code have been adapted from contributors of this board,
hth
Colin
Click to expand...
 
Upvote 0
Isabella,

I dont require the code to add worksheets the worksheets are already set.
Click to expand...


I will adjust the code to just work with the two output worksheets, SMPJPD15, and SMPUB915,


And, when you reply to a post, you do not have to quote the helpers reply.
 
Upvote 0
Isabella,


Sample raw data:


Excel Workbook
ABCDEFGHIJK
4PfCodeSecurity* * * * * Short NameReportGroupCategory&SubtypeIDNumberTransShortNameBrokerCode*ContractDate*SettlementDate* * * *TransUnits
5RSTAHYSMPJPD15SMP JP 061215 CC * *85DS04157957DS-PURJPMAUD22/12/201022/12/2010-3,500,000.00
6RSTAHYSMPJPD15SMP JP 061215 CC * *85DS04158305DS-PURJPMAUD23/12/201023/12/2010-440,000.00
7RSTBFASMPJPD15SMP JP 061215 CC * *85DS04157959DS-PURJPMAUD22/12/201022/12/2010-3,150,000.00
8RSTBFASMPJPD15SMP JP 061215 CC * *85DS04158304DS-PURJPMAUD23/12/201023/12/2010-480,000.00
9RTFDBGSMPJPD15SMP JP 061215 CC * *85DS04157958DS-PURJPMAUD22/12/201022/12/2010-770,000.00
10RTFDBGSMPJPD15SMP JP 061215 CC * *85DS04160168DS-PURJPMSYD30/12/201030/12/2010-280,000.00
11RTFDBGSMPJPD15SMP JP 061215 CC * *85DS04160457INT *INT *31/12/201031/12/20100.00
12RTEYFGSMPUB915SMP UBS 092015 CC *85DS04150708DS-PURUBSAUD3/12/20103/12/2010-380,000.00
13RTEYFGSMPUB915SMP UBS 092015 CC *85DS04151121DS-PURUBSAUD6/12/20106/12/2010-440,000.00
14RTEYFGSMPUB915SMP UBS 092015 CC *85DS04152649DS-PURUBSAUD8/12/20108/12/2010-520,000.00
15RTFDBGSMPUB915SMP UBS 092015 CC *85DS04154816DS-PURUBSAUD14/12/201014/12/2010-260,000.00
16RTFDBGSMPUB915SMP UBS 092015 CC *85DS04155882DS-PURUBSAUD16/12/201016/12/2010-570,000.00
17RTFDBGSMPUB915SMP UBS 092015 CC *85DS04158291DS-PURUBSAUD23/12/201023/12/2010-490,000.00
18RTFDBGSMPUB915SMP UBS 092015 CC *85DS04159263DS-PURUBSAUD29/12/201029/12/2010-520,000.00
19RSTBFASMPUB915SMP UBS 092015 CC *85DS04160460INT *INT *31/12/201031/12/20100.00
20RSTBFASMPUB915SMP UBS 092015 CC *85DS04160656DS-PURUBSAUD31/12/201031/12/2010-320,000.00
21
RawData





Excel Workbook
ABCDEFGHIJK
5PfCodeSecurity* * * * * Short NameReportGroupCategory&SubtypeIDNumberTransShortNameBrokerCode*ContractDate*SettlementDate* * * *TransUnits
6
7
8
9
10
11
12
13
SMPJPD15





Excel Workbook
ABCDEFGHIJK
5PfCodeSecurity* * * * * Short NameReportGroupCategory&SubtypeIDNumberTransShortNameBrokerCode*ContractDate*SettlementDate* * * *TransUnits
6
7
8
9
10
11
12
13
14
15
SMPUB915





After the macro:


Excel Workbook
ABCDEFGHIJK
5PfCodeSecurity* * * * * Short NameReportGroupCategory&SubtypeIDNumberTransShortNameBrokerCode*ContractDate*SettlementDate* * * *TransUnits
6RSTAHYSMPJPD15SMP JP 061215 CC * *85DS04157957DS-PURJPMAUD22/12/201022/12/2010-3,500,000.00
7RSTAHYSMPJPD15SMP JP 061215 CC * *85DS04158305DS-PURJPMAUD23/12/201023/12/2010-440,000.00
8RSTBFASMPJPD15SMP JP 061215 CC * *85DS04157959DS-PURJPMAUD22/12/201022/12/2010-3,150,000.00
9RSTBFASMPJPD15SMP JP 061215 CC * *85DS04158304DS-PURJPMAUD23/12/201023/12/2010-480,000.00
10RTFDBGSMPJPD15SMP JP 061215 CC * *85DS04157958DS-PURJPMAUD22/12/201022/12/2010-770,000.00
11RTFDBGSMPJPD15SMP JP 061215 CC * *85DS04160168DS-PURJPMSYD30/12/201030/12/2010-280,000.00
12RTFDBGSMPJPD15SMP JP 061215 CC * *85DS04160457INT *INT *31/12/201031/12/20100.00
13
SMPJPD15





Excel Workbook
ABCDEFGHIJK
5PfCodeSecurity* * * * * Short NameReportGroupCategory&SubtypeIDNumberTransShortNameBrokerCode*ContractDate*SettlementDate* * * *TransUnits
6RTEYFGSMPUB915SMP UBS 092015 CC *85DS04150708DS-PURUBSAUD3/12/20103/12/2010-380,000.00
7RTEYFGSMPUB915SMP UBS 092015 CC *85DS04151121DS-PURUBSAUD6/12/20106/12/2010-440,000.00
8RTEYFGSMPUB915SMP UBS 092015 CC *85DS04152649DS-PURUBSAUD8/12/20108/12/2010-520,000.00
9RTFDBGSMPUB915SMP UBS 092015 CC *85DS04154816DS-PURUBSAUD14/12/201014/12/2010-260,000.00
10RTFDBGSMPUB915SMP UBS 092015 CC *85DS04155882DS-PURUBSAUD16/12/201016/12/2010-570,000.00
11RTFDBGSMPUB915SMP UBS 092015 CC *85DS04158291DS-PURUBSAUD23/12/201023/12/2010-490,000.00
12RTFDBGSMPUB915SMP UBS 092015 CC *85DS04159263DS-PURUBSAUD29/12/201029/12/2010-520,000.00
13RSTBFASMPUB915SMP UBS 092015 CC *85DS04160460INT *INT *31/12/201031/12/20100.00
14RSTBFASMPUB915SMP UBS 092015 CC *85DS04160656DS-PURUBSAUD31/12/201031/12/2010-320,000.00
15
SMPUB915





Please TEST this FIRST in a COPY of your workbook (always make a backup copy before trying new code, you never know what you might lose).


1. Copy the below code, by highlighting the code and pressing the keys CTRL + C
2. Open your workbook
3. Press the keys ALT + F11 to open the Visual Basic Editor
4. Press the keys ALT + I to activate the Insert menu
5. Press M to insert a Standard Module
6. Where the cursor is flashing, paste the code by pressing the keys CTRL + V
7. Press the keys ALT + Q to exit the Editor, and return to Excel
8. To run the macro from Excel, open the workbook, and press ALT + F8 to display the Run Macro Dialog. Double Click the macro's name to Run it.


Code: 
Option Explicit
Sub DistributeRows()
' hiker95, 03/05/2011
' http://www.mrexcel.com/forum/showthread.php?t=533700
Dim w1 As Worksheet
Dim LR As Long, a As Long, NR As Long, WSary
Application.ScreenUpdating = False
WSary = Array("SMPJPD15", "SMPUB915")
With Worksheets("RawData")
  LR = .Cells(Rows.Count, 1).End(xlUp).Row
  .AutoFilterMode = False
  With .Range("A4:K" & LR)
    For a = LBound(WSary) To UBound(WSary)
      .AutoFilter Field:=2, Criteria1:=WSary(a)
      NR = Worksheets(WSary(a)).Range("A" & Rows.Count).End(xlUp).Offset(1).Row
      On Error Resume Next
      .Offset(1).Resize(.Rows.Count - 1).SpecialCells(12).Copy Worksheets(WSary(a)).Range("A" & NR)
      On Error GoTo 0
      .AutoFilter
    Next a
  End With
End With
Application.ScreenUpdating = True
End Sub


Then run the DistributeRows macro.
 
Upvote 0
You must log in or register to reply here.

Similar threads

A
  • Question
How to Insert another loop for inputting multiple receiver name in an Email based on criteria
Replies
3
Views
480
portews
P
M
  • Question
Need to add _AfterUpdate events to a dynamically-created class
Replies
1
Views
889
Matrovsky
M
F
  • Question
First time coding, want help optimizing a long macro
Replies
0
Views
908
fcats
F
S
  • Question
VBA Code help
Replies
2
Views
966
skmcrodgers
S
V
  • Question
VBA to pull emails from outlook
Replies
1
Views
4K
Macropod
Macropod

Forum statistics

Threads
1,214,826
Messages
6,121,794
Members
449,048
Latest member
greyangel23

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