PDA

View Full Version : Loop through code, move across a columns



RINCONPAUL
07-31-2015, 04:27 PM
I have recorded a macro but it's pretty long. It's basically: At source Sheet1, select copy from col B, move to Sheet5 sort and remove duplicates and paste in col A. Then repeat loop but this time move across one column at source B to C and return to Sheet 5 and paste two cols over from previous Col C to E. Repeat loop.

So, it's shunting across one column at source and two columns at destination sheet, each loop. The source sheet starts at col B and ends at col Y. The destination sheet starts at col A and finishes at col AU. Code attached for two cycles of the loop.

Thanks for reading :)

#Sub Criteriadropdownpaste()
'
' Criteriadropdownpaste Macro
'
'
Sheets("Sheet1").Select
Range("B3").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("Sheet5").Select
Range("A2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
ActiveWorkbook.Worksheets("Sheet5").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Sheet5").Sort.SortFields.Add Key:=Range("A2"), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Sheet5").Sort
.SetRange Range("A2:A20000")
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
ActiveSheet.Range("$A$1:$A$20000").RemoveDuplicates Columns:=1, Header:= _
xlYes
Sheets("Sheet1").Select
Range("C3").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("Sheet5").Select
Range("C2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
ActiveWorkbook.Worksheets("Sheet5").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Sheet5").Sort.SortFields.Add Key:=Range("C2"), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Sheet5").Sort
.SetRange Range("C2:C20000")
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
ActiveSheet.Range("$C$1:$C$20000").RemoveDuplicates Columns:=1, Header:= _
xlYes#

p45cal
08-01-2015, 02:30 AM
try this but make sure that sheet 5 is clear first:
Sub blah()
With Sheets("Sheet5")
For Each cll In Sheets("Sheet1").Range("B3:Y3").Cells
Set Destn = .Cells(2, cll.Column * 2 - 3)
Sheets("Sheet1").Range(cll, cll.End(xlDown)).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Destn, Unique:=True
With .Sort
.SortFields.Clear
.SortFields.Add Key:=Destn, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SetRange Range(Destn, Destn.End(xlDown))
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Next cll
End With
End Sub

RINCONPAUL
08-01-2015, 11:35 AM
A genius no more Pascal, a SUPER GENIUS, by any other name. You've conquered again, well done.

Thanks sooo much :) Case closed