Loop and split values based on criteria

P

Pranesh

Board Regular
Joined
Jun 29, 2014
Messages
219
Hi all,
I have a set of data for which I need to calculate % split based on criteria on sheet2. I have recorded it for 1 criteria which is in row2. I have till rows 15. Don't no how to loop it till end and im afraid that my code also will get increased. Below is the recorded code.
Please help me to make it simple and loop until last keyed cell.
Code: 
Sub Macro1()
'
' Macro1 Macro
'
    Sheet2.Select
    Range("B2").Select
    Findstring = Selection.Value
    Selection.Copy
    Sheet3.Select
    ActiveSheet.Range("A:AH").AutoFilter Field:=11, Criteria1:=Findstring
    Application.CutCopyMode = False
    Range("A2:AB2").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    Sheet4.Select
    Range("A1").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    Range("X1:AB1").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    Range("AC1").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    Sheet2.Select
    Range("C2").Select
    Selection.Copy
    Sheet4.Select
    Range("X2:AB2").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlMultiply, _
        SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
    Selection.Style = "Currency"
    Range("A1:AB1").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    Sheet5.Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    Sheet2.Select
    Range("C1").Select
    Selection.Copy
    Sheet5.Select
    Range("AC2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    Sheet4.Select
    Range("AC2:AG2").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    Range("X2").Select
    Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
        xlNone, SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
    Sheet2.Select
    Range("D2").Select
    Selection.Copy
    Sheet4.Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlMultiply, _
        SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
    Selection.Style = "Currency"
    Range("A2:AB2").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    Sheet5.Select
    Range("A1048576").Select
    Selection.End(xlUp).Select
    ActiveCell.Offset(1, 0).Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    Sheet2.Select
    Range("D1").Select
    Selection.Copy
    Sheet5.Select
    Range("AC1048576").Select
    Selection.End(xlUp).Select
    ActiveCell.Offset(1, 0).Select
    ActiveCell.Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    Range("AB1048576").Select
    Selection.End(xlUp).Select
    ActiveCell.Offset(0, 1).Select
    Range(Selection, Selection.End(xlUp)).Select
    Selection.FillDown
    
    Sheet4.Select
    Range("AC2:AG2").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    Range("X2").Select
    Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
        xlNone, SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
    Sheet2.Select
    Range("E2").Select
    Selection.Copy
    Sheet4.Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlMultiply, _
        SkipBlanks:=False, Transpose:=False
    Selection.Style = "Currency"
    Application.CutCopyMode = False
    Range("A2:AB2").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    Sheet5.Select
    Range("A1048576").Select
    Selection.End(xlUp).Select
    ActiveCell.Offset(1, 0).Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    Sheet2.Select
    Range("E1").Select
    Selection.Copy
    Sheet5.Select
    Range("AC1048576").Select
    Selection.End(xlUp).Select
    ActiveCell.Offset(1, 0).Select
    ActiveCell.Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    Range("AB1048576").Select
    Selection.End(xlUp).Select
    ActiveCell.Offset(0, 1).Select
    Range(Selection, Selection.End(xlUp)).Select
    Selection.FillDown
        
    End Sub
 

Excel Facts

Repeat Last Command
Pressing F4 adds dollar signs when editing a formula. When not editing, F4 repeats last command.
Sort by date Sort by votes
Pranuvins said:
Hi all,
I have a set of data for which I need to calculate % split based on criteria on sheet2. I have recorded it for 1 criteria which is in row2. I have till rows 15. Don't no how to loop it till end and im afraid that my code also will get increased. Below is the recorded code.
Please help me to make it simple and loop until last keyed cell.
Code: 
Sub Macro1()
'
' Macro1 Macro
'
    Sheet2.Select
    Range("B2").Select
    Findstring = Selection.Value
    Selection.Copy
    Sheet3.Select
    ActiveSheet.Range("A:AH").AutoFilter Field:=11, Criteria1:=Findstring
    Application.CutCopyMode = False
    Range("A2:AB2").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    Sheet4.Select
    Range("A1").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    Range("X1:AB1").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    Range("AC1").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    Sheet2.Select
    Range("C2").Select
    Selection.Copy
    Sheet4.Select
    Range("X2:AB2").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlMultiply, _
        SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
    Selection.Style = "Currency"
    Range("A1:AB1").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    Sheet5.Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    Sheet2.Select
    Range("C1").Select
    Selection.Copy
    Sheet5.Select
    Range("AC2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    Sheet4.Select
    Range("AC2:AG2").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    Range("X2").Select
    Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
        xlNone, SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
    Sheet2.Select
    Range("D2").Select
    Selection.Copy
    Sheet4.Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlMultiply, _
        SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
    Selection.Style = "Currency"
    Range("A2:AB2").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    Sheet5.Select
    Range("A1048576").Select
    Selection.End(xlUp).Select
    ActiveCell.Offset(1, 0).Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    Sheet2.Select
    Range("D1").Select
    Selection.Copy
    Sheet5.Select
    Range("AC1048576").Select
    Selection.End(xlUp).Select
    ActiveCell.Offset(1, 0).Select
    ActiveCell.Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    Range("AB1048576").Select
    Selection.End(xlUp).Select
    ActiveCell.Offset(0, 1).Select
    Range(Selection, Selection.End(xlUp)).Select
    Selection.FillDown
    
    Sheet4.Select
    Range("AC2:AG2").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    Range("X2").Select
    Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
        xlNone, SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
    Sheet2.Select
    Range("E2").Select
    Selection.Copy
    Sheet4.Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlMultiply, _
        SkipBlanks:=False, Transpose:=False
    Selection.Style = "Currency"
    Application.CutCopyMode = False
    Range("A2:AB2").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    Sheet5.Select
    Range("A1048576").Select
    Selection.End(xlUp).Select
    ActiveCell.Offset(1, 0).Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    Sheet2.Select
    Range("E1").Select
    Selection.Copy
    Sheet5.Select
    Range("AC1048576").Select
    Selection.End(xlUp).Select
    ActiveCell.Offset(1, 0).Select
    ActiveCell.Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    Range("AB1048576").Select
    Selection.End(xlUp).Select
    ActiveCell.Offset(0, 1).Select
    Range(Selection, Selection.End(xlUp)).Select
    Selection.FillDown
        
    End Sub
Click to expand...

Hello all,

If you have any doubts or you couldn't understand the content please revert me back.
 
Upvote 0
You must log in or register to reply here.

Similar threads

J
  • Question
VBA to select partial filename and go back and forth between two files to copy paste
Replies
1
Views
163
shknbk2
S
N
  • Question
VBA Questions - Copying dynamic data from one tab to another and deleting filtered rows
Replies
1
Views
183
DanteAmor
DanteAmor
S
  • Solved
VBA does not continue to copy after blank cell
Replies
8
Views
520
jolivanes
jolivanes
P
  • Solved
Recorded Macro Ammendments
Replies
3
Views
342
Joe4
Joe4
P
  • Solved
Counter in For Each loop
Replies
2
Views
193
Possum17
P

Forum statistics

Threads
1,214,833
Messages
6,121,857
Members
449,051
Latest member
excelquestion515

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