I'm trying to build a basic macro that will sort my data:
Sub Makro1()
Range("N1").Select
Selection.Copy
Range("A2").Select
ActiveSheet.Paste
Range("N2").Select
Application.CutCopyMode = False
Selection.Copy
Range("D2").Select
ActiveSheet.Paste
Range("N3").Select
Application.CutCopyMode = False
Selection.Copy
Range("C2").Select
ActiveSheet.Paste
My data is N columns and one record takes 3 cells that I would like to copy to one row as above.
Now I would like the VBA to keep copying until data in column N ends.
So N4 to A3, N5 to C3 as so on and on.
I'm pretty new to VBA.
Thanks !
Like this?
Public Sub testing()
Dim i As Long
Application.ScreenpUpdating = False
With ActiveSheet
For i = 1 To .Cells(.Rows.Count, "N").End(xlUp).Row Step 3
.Cells(i + 1, "A") = .Cells(i, "N")
.Cells(i + 1, "D") = .Cells(i + 1, "N")
.Cells(i + 1, "C") = .Cells(i + 2, "N")
Next i
End With
Application.ScreenpUpdating = True
End Sub
Transforms column N to the left as shown:
You can delete or hide empty column A rows with
.Range(.Cells(2, "A"), .Cells(.Cells(.Rows.Count, "N").End(xlUp).Row, "A")).SpecialCells(xlBlanks).Delete
or
.Range(.Cells(2, "A"), .Cells(.Cells(.Rows.Count, "N").End(xlUp).Row, "A")).SpecialCells(xlBlanks).EntireRow.Hidden = True
Related
I'm trying to have a "Called Sub" paste data after the last row used in the one that is calling the code.
However, I can only manage to have the first sub to paste the first data selected and when "ESTDEUDA" is called it pastes the other data on information first used.
Sub ActualizarFondos()
'Deuda
J = 12
For i = 15 To 26
Sheets("Reporte").Activate
If Cells(i, "C").Value > 0 Then
Range(Cells(i, "C"), Cells(i, "B")).Copy
ActiveSheet.Range(Cells(J, "Z"), Cells(J, "AA")).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'Call ESTDEUDA
J = J + 1
End If
Next
End Sub
Sub ESTDEUDA()
J = 12
For i = 3 To 6
Sheets("FondosEstrategia").Activate
If Cells(i, "F").Value > 0 Then
Range(Cells(i, "E"), Cells(i, "F")).Select
Range(Cells(i, "E"), Cells(i, "F")).Copy
Sheets("Reporte").Activate
Range(Cells(J, "Z"), Cells(J, "AA")).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
J = J + 1
End If
End Sub
I'd like to know what can be done in order to have the information from sheet "FondosEstrategia" to be pasted after the infomation pasted from sheet "Reporte".
Is there any way that a kind of J = J +1 is applied to "ESTDEUDA" in order to paste after J = J +1 from "ActualizarFondos".
Thanks!
You do not need to use J. Just offset your i value in your first loop to produce desired J value.
On your first loop:
i = 15
J = 12 which is the same is i - 3.
Therefore, you can swap out every instance of J with i - 3.
Next, you can pass i as a parameter (input) into ESTDEUDA using the below method.
Sub ActualizarFondos()
Dim i As Integer
For i = 15 To 26
With Sheets("Reporte")
If .Cells(i, "C").Value > 0 Then
.Range(.Cells(i, "C"), .Cells(i, "B")).Copy
ThisWorkbook.Sheets("WHATSHEET").Range("Z" & i - 3).PasteSpecial Paste:=xlPasteValues
Call ESTDEUDA(i)
End If
End With
Next i
End Sub
Sub ESTDEUDA(i As Integer)
Dim x As Long
For x = 3 To 6
With Sheets("FondosEstrategia")
If .Cells(x, "F").Value > 0 Then
.Range(.Cells(x, "E"), .Cells(x, "F")).Copy
Sheets("Reporte").Range("Z" & i - 3).PasteSpecial Paste:=xlPasteValues
End If
End With
Next x
End Sub
Also, you need to qualify your instances of Range and Cells with a direct sheet. You should avoid relying to Active or Selected sheet.
I am trying to transfer the data from sheet one to sheet two and combined the information on the second sheet. The code I have listed below works, but it seems very inefficient. I am trying to improve by VBA abilities and would love to here ways to shrink my code down, make it more efficient, and still achieve the same goal. Thanks for any help you can provide.
Sheet 1
Sheet 2
Sub batchorder()
Dim Pname As String
Dim Lplace As String
Dim numsld As Long
Dim rating As Integer
Dim lastrow As Long
Dim i As Long
Dim openc As Long
lastrow = Range("A" & Rows.Count).End(xlUp).Row
Range("A1").Select
For i = 1 To lastrow
If Cells(i, 1).Value <> "" Then
'Copy name to sheet 2
Cells(i, 1).Select
ActiveCell.Offset(0, 1).Select
Selection.Copy
Sheets("Sheet2").Select
Range("A1").Select
'Find the next open cell to paste to
Selection.End(xlDown).Select
Selection.End(xlDown).Select
Selection.End(xlUp).Select
ActiveCell.Offset(1, 0).Select
ActiveSheet.Paste
Sheets("Sheet1").Select
'Copy place to sheet 2
ActiveCell.Offset(1, 0).Select
Selection.Copy
Sheets("Sheet2").Select
Range("B1").Select
'Find the next open cell to paste to
Selection.End(xlDown).Select
Selection.End(xlDown).Select
Selection.End(xlUp).Select
ActiveCell.Offset(1, 0).Select
ActiveSheet.Paste
Sheets("Sheet1").Select
'Copy sold to sheet 2
ActiveCell.Offset(1, 0).Select
Selection.Copy
Sheets("Sheet2").Select
Range("C1").Select
'Find the next open cell to paste to
Selection.End(xlDown).Select
Selection.End(xlDown).Select
Selection.End(xlUp).Select
ActiveCell.Offset(1, 0).Select
ActiveSheet.Paste
Sheets("Sheet1").Select
'Copy rating to sheet 2
ActiveCell.Offset(1, 0).Select
Selection.Copy
Sheets("Sheet2").Select
Range("D1").Select
'Find the next open cell to paste to
Selection.End(xlDown).Select
Selection.End(xlDown).Select
Selection.End(xlUp).Select
ActiveCell.Offset(1, 0).Select
ActiveSheet.Paste
Sheets("Sheet1").Select
Sheets("Sheet1").Select
i = i + 3
Else
End If
Next i
End Sub
Sub batchorder()
Dim Row As Long
Dim i As Long
' These two lines speed up evrything ENORMOUSLY.
' But you need the lines at the end too
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Row = Sheet2.UsedRange.Rows.Count ' Row is nr of last row in sheet
While Application.CountA(Sheet2.Rows(Row)) = 0 And Row > 1
Row = Row - 1 ' skip empty rows at the end if present
Wend
For i = 1 To Sheet1.UsedRange.Rows.Count
If Sheet1.Cells(i, 1).Value <> "" Then
Sheet2.Cells(Row, 1).FormulaLocal = Sheet1.Cells(i, 2).FormulaLocal
Sheet2.Cells(Row, 2).FormulaLocal = Sheet1.Cells(i + 1, 2).FormulaLocal
Sheet2.Cells(Row, 3).FormulaLocal = Sheet1.Cells(i + 2, 2).FormulaLocal
Sheet2.Cells(Row, 4).FormulaLocal = Sheet1.Cells(i + 3, 2).FormulaLocal
i = i + 3
Row = Row + 1
End If
Next
' Restore Excel to human state.
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
You should basically never use the select statement, it gets everything really messy quickly. Here's a basic combiner of mine. Just added the If statement to check whether the cell and in this case row is empty.
This should work but more importantly try to understand what it does to learn. I gave it some comments.
Sub batchorder()
Dim ws1 As Worksheet
Dim ws2 As Worksheet
' Just habits, but doing this here means that I won't have to write anything else than ws1 and ws2 in the future
Set ws1 = Worksheets("Sheet1")
Set ws2 = Worksheets("Sheet2")
Dim lastrowWs1 As Long
Dim j As Long
' first row after ws2 headers
j = 2
' With statement to make the code nicer also ".something" now means ws1.something
With ws1
' Bob Ulmas method -- just a personal preference to find the last row.
lastrowWs1 = .Cells.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row
For i = 1 To lastrowWs1
' Check if the cell is not empty
If Not .Cells(i, 1) = vbNullString Then
'Basically range.value = other_range.value
ws2.Range(ws2.Cells(j, 1), ws2.Cells(j, 4)).Value = WorksheetFunction.Transpose(.Range(.Cells(i, 2), .Cells(i + 3, 2)).Value)
' step 3 forward as the amount of rows per record was 4
i = i + 3
' go to next row for worksheet 2
j = j + 1
End If
Next i
End With
End Sub
I modified the code only at one point because it was what I needed but I need something extra and I can't figure out how to do it.
Here is the original code from this post :
Sub test()
Dim lastRow As Integer, i As Integer
Dim cel As Range, rng As Range, sortRng As Range
Dim curString As String, nextString As String
Dim haveHeaders As Boolean
haveHeaders = False ' Change this to TRUE if you have headers.
lastRow = Cells(1, 1).End(xlDown).Row
If haveHeaders Then 'If you have headers, we'll start the ranges in Row 2
Set rng = Range(Cells(2, 1), Cells(lastRow, 1))
Set sortRng = Range(Cells(2, 1), Cells(lastRow, 2))
Else
Set rng = Range(Cells(1, 1), Cells(lastRow, 1))
Set sortRng = Range(Cells(1, 1), Cells(lastRow, 2))
End If
' First, let's resort your data, to get all of the "Column A" values in order, which will group all duplicates together
With ActiveSheet
.Sort.SortFields.Clear
.Sort.SortFields.Add Key:=rng, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With .Sort
.SetRange sortRng
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
' Now, let's move all "Column B" data for duplicates into Col. C
' We can check to see if the cell's value is a duplicate by simply counting how many times it appears in `rng`
Dim isDuplicate As Integer, firstInstanceRow As Integer, lastInstanceRow As Integer
If haveHeaders Then
curString = Cells(2, 1).Value
Else
curString = Cells(1, 1).Value
End If
Dim dupRng As Range 'set the range for the duplicates
Dim k As Integer
k = 0
For i = 1 To lastRow
If i > lastRow Then Exit For
Cells(i, 1).Select
curString = Cells(i, 1).Value
nextString = Cells(i + 1, 1).Value
isDuplicate = WorksheetFunction.CountIf(rng, Cells(i, 1).Value)
If isDuplicate > 1 Then
firstInstanceRow = i
Do While Cells(i, 1).Offset(k, 0).Value = nextString
'Cells(i, 1).Offset(k, 0).Select
lastInstanceRow = Cells(i, 1).Offset(k, 0).Row
k = k + 1
Loop
Range(Cells(firstInstanceRow + 1, 2), Cells(lastInstanceRow, 3)).Copy
Cells(firstInstanceRow, 5).PasteSpecial xlPasteValues
Application.CutCopyMode = False
Range(Rows(firstInstanceRow + 1), Rows(lastInstanceRow)).EntireRow.Delete
k = 0
lastRow = Cells(1, 1).End(xlDown).Row
End If
Next i
End With
End Sub
What I did is:
changed this:
Range(Cells(firstInstanceRow + 1, 2), Cells(lastInstanceRow, 2)).Copy
Cells(firstInstanceRow, 3).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
Application.CutCopyMode = False
to
Range(Cells(firstInstanceRow + 1, 2), Cells(lastInstanceRow, 3)).Copy
Cells(firstInstanceRow, 5).PasteSpecial xlPasteValues
Application.CutCopyMode = False
What I have is:
Column A has duplicates.
Column B has unique value.
And column C has the qty for the unique values.
It works until the copy and paste part with the exception that it copies either column C under value from column B or the other way is that it copies each value from Column B with the qty from Column C but when it finishes, it deletes all the duplicates.
Example
Column A Column B column C
322 sku322 qty 20
322 322sku qty 25
it outputs like
Column D column E
sku322 qty 20
322sku qty 25
And when it's finished, it delete the second row. This means that i don't have the second unique value.
Or it outputs like:
Column D Column E
sku322 322sku
qty 20 qty 25
And then it delete the last row and I don't have the qty anymore.
From my way of thinking if there is no way to paste on the same line, that would mean that after each find it should retake the loop and not copy/paste in bulk. But I tried multiple ways and can't seem to find a way to make it work.
Hows this? Screenshot of the results:
Note: If you want the ENTIRE 'unique-sku' column instead of just the country code, change
country = Right(Cells(i, 2), 2)
to
country = Cells(i, 2).Value
Code:
Sub Macro1()
'
' Macro1 Macro
'
Dim country As String, qty As Integer
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
' Headers
dict("country") = "sum"
' Loop through all rows starting on row 2; per Column A
For i = 2 To Sheets("Sheet1").Cells(1, 1).End(xlDown).Row
' Country = last 2 letters of Column B
country = Right(Cells(i, 2), 2)
qty = CInt(Cells(i, 3).Value)
' If it already exists, add the new amount to the sum.
If dict.Exists(country) Then
qty = dict(country) + qty
End If
' This will create it if it doesn't already exist. Otherwise, update.
dict(country) = qty
Next
' Here are some display options.
' Horizontal
Range("F2").Resize(1, UBound(dict.Keys()) + 1).Value = dict.Keys()
Range("F3").Resize(1, UBound(dict.Items()) + 1).Value = dict.Items()
' Vertical
Range("F5").Resize(UBound(dict.Keys()) + 1).Value = WorksheetFunction.Transpose(dict.Keys())
Range("G5").Resize(UBound(dict.Items()) + 1).Value = WorksheetFunction.Transpose(dict.Items())
Set dict = Nothing
'
End Sub
So i found a workaround, i don't know if it's the most feasable one but it works and for 10.000 rows it does it in 40 seconds to 1 minute max.
You need to create 3 modules and a function (i did not want to put the function in the on the modules.
Module 1
Sub Simplify()
Application.Run "Module9.RemovePart"
Application.Run "Module10.SameRowDuplicates"
End Sub
Module 2
Private Sub RemovePart()
Dim fndList As Variant
Dim fndRplc As Variant
With ActiveSheet
Range("B1").EntireColumn.Insert 'Here i inserted a new column so i can duplicate the first column
Range("A1", Range("A" & Rows.Count).End(xlUp)).Copy ' Copied the first column to the inserted one
Range("B1", Range("B" & Rows.Count).End(xlUp)).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False
Application.CutCopyMode = False
lastRow = Cells(Rows.Count, "A").End(xlUp).Row ' selected first column to remove the end of the sku
fndList = Array("FR", "DE", "ES") ' here you can just change to whatevery you want to remove
fndRplc = "" ' here is what it replaces it with
For x = LBound(fndList) To UBound(fndList)
For i = lastRow To 1 Step -1
Range("A1").EntireColumn.Replace What:=fndList(x), Replacement:=fndRplc, _
LookAt:=xlPart, SearchOrder:=xlByColumns, MatchCase:=False, _
SearchFormat:=False, ReplaceFormat:=False
Next i
Next x
End With
End Sub
Module 3
Private Sub SameRowDuplicates()
Dim lastRow As Integer, i As Integer
Dim cel As Range, Rng As Range, sortRng As Range
Dim curString As String, nextString As String
Dim haveHeaders As Boolean
haveHeaders = True ' Change this to TRUE if you have headers.
lastRow = Cells(1, 1).End(xlDown).Row
If haveHeaders Then 'If you have headers, we'll start the ranges in Row 2
Set Rng = Range(Cells(2, 1), Cells(lastRow, 1))
Set sortRng = Range("A2").CurrentRegion
Else
Set Rng = Range(Cells(1, 1), Cells(lastRow, 1))
Set sortRng = Range("A1").CurrentRegion
End If
' First, let's resort your data, to get all of the "Column A" values in order, which will group all duplicates together
With ActiveSheet
.Sort.SortFields.Clear
.Sort.SortFields.Add Key:=Rng, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With .Sort
.SetRange sortRng
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
' Now, let's move all "Column B" data for duplicates into Col. C
' We can check to see if the cell's value is a duplicate by simply counting how many times it appears in `rng`
Dim isDuplicate As Integer, firstInstanceRow As Integer, lastInstanceRow As Integer
If haveHeaders Then
curString = Cells(2, 1).Value
Else
curString = Cells(1, 1).Value
End If
Dim dupRng As Range 'set the range for the duplicates
Dim k As Integer
k = 0
For i = 1 To lastRow
If i > lastRow Then Exit For
Cells(i, 1).Select
curString = Cells(i, 1).Value
nextString = Cells(i + 1, 1).Value
isDuplicate = WorksheetFunction.CountIf(Rng, Cells(i, 1).Value)
If isDuplicate > 1 Then
firstInstanceRow = i
Do Until Cells(i, 1).Offset(k, 0).Value <> nextString
'Cells(i, 1).Offset(k, 0).Select
lastInstanceRow = Cells(i, 1).Offset(k, 0).Row
k = k + 1
Loop
Cells(firstInstanceRow, 5).Formula = "=Combine(" & Range(Cells(firstInstanceRow + 1, 2), Cells(lastInstanceRow, 3)).Address(False, False) & ")" ' combine the results in one row so you have all the duplicates one after another
Cells(firstInstanceRow, 5).Copy
Cells(firstInstanceRow, 5).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False
Application.CutCopyMode = False
Selection.TextToColumns DataType:=xlDelimited, _ ' this is for converting comma delimited to columns
ConsecutiveDelimiter:=False, Semicolon:=True ' here you should change your delimiter to what you are using
Range(Rows(firstInstanceRow + 1), Rows(lastInstanceRow)).EntireRow.Delete
k = 0
lastRow = Cells(1, 1).End(xlDown).Row
End If
Next i
End With
End Sub
Function 1
Function Combine(WorkRng As Range, Optional Sign As String = ";") As String
'Update 20130815
Dim Rng As Range
Dim OutStr As String
For Each Rng In WorkRng
If Rng.Text <> ";" Then
OutStr = OutStr & Rng.Text & Sign
End If
Next
Combine = Left(OutStr, Len(OutStr) - 1)
End Function
So quick story:
Module 1 calls for the other modules, i did it this way to make things easier for the end-user so he doesn't see all the modules just needs to click one.
Module 2 removes any text from the selected cells
Module 3 finds the duplicates and puts them on one line delimited by what you select in the function module. And then deletes the duplicates row.
Function 1 takes the output of you selection and puts it on one row delimited.
That is all, thanks for everybody's help and i wish this will help others.
I would like your help in helping me figure out how to take a row of cells that are in a flat hierarchy (Cell A:1 = level 1, Cell A:2 = level 2 etc...) and build it out so that each level is on a separate row like a straw model.
What I need:
To-Be What I need
And then this is what I have for example:
As-Is Flat hierarchy
I Just can't wrap my head around what is needed as I have got the code to move cells down and look like a hierarchy but I can't seem to get the logic tweaked just right to give me a clean smooth looking sheet. I will have a lot of different parents with different hierarchies and don't want to have to keep going through them and manually copying and pasting the values.
Here is the code I have been using that I have pulled together from other stackoverflow questions and it gets me somewhat on the right track but need help to see what I am missing to get it to look like the To-Be image above. The code assumes that I have 8 levels in a hierarchy but I want to programically find the lowest level of each hierarchy (most granular level) and skip the idea of having to create and if statement for each level as I could have some hierarchies with 30 child sub levels. : Thoughts?
Sub Button1_Click()
Dim rng As Range
Dim row As Range
Dim cell As Range
Dim lcol As Long
For x = 8 To 1 Step -1
lcol = Cells(x, Columns.Count).End(xlToLeft).Column
If IsEmpty(Cells(x, 8)) = False Then
Cells(x, 8).Select
For Z = 1 To 8
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Rows(lcol).EntireRow.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Next
End If
If IsEmpty(Cells(x, 7)) = False Then
Cells(x, 7).Select
For Z = 1 To 7
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Next
End If
If IsEmpty(Cells(x, 6)) = False Then
Cells(x, 6).Select
For Z = 1 To 6
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Next
End If
If IsEmpty(Cells(x, 5)) = False Then
Cells(x, 5).Select
For Z = 1 To 5
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Next
End If
If IsEmpty(Cells(x, 4)) = False Then
Cells(x, 4).Select
For Z = 1 To 4
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Next
End If
If IsEmpty(Cells(x, 3)) = False Then
Cells(x, 3).Select
For Z = 1 To 3
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Next
End If
If IsEmpty(Cells(x, 2)) = False Then
Cells(x, 2).Select
For Z = 1 To 2
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Next
End If
If IsEmpty(Cells(x, 1)) = False Then
Cells(x, 1).Select
For Z = 1 To 1
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Next
End If
Next
End Sub
I'd use arrays extensively, like follows:
Option Explicit
Sub main()
Dim myArr As Variant, myArr2() As String
Dim irow As Long, iCol As Long, irow2 As Long
With Worksheets("Hierarchy").Range("A1").CurrentRegion
myArr = .Cells.value
ReDim myArr2(1 To WorksheetFunction.CountA(.Cells) + .Rows.Count - 1, 1 To .Columns.Count)
End With
For irow = LBound(myArr, 1) To UBound(myArr, 1)
For iCol = LBound(myArr, 2) To UBound(myArr, 2)
If Not IsEmpty(myArr(irow, iCol)) Then
irow2 = irow2 + 1
myArr2(irow2, iCol) = myArr(irow, iCol)
End If
Next iCol
irow2 = irow2 + 1
Next irow
Worksheets("Hierarchy").Range("A1").Range("A1").Resize(UBound(myArr2, 1), UBound(myArr2, 2)).value = myArr2
End Sub
the below code will do the job
Sub Button1_Click()
i = 1
row_loc = 2
Do While Cells(i, 1).Value <> ""
childs = Cells(i, Columns.Count).End(xlToLeft).Column - 1
For j = 1 To childs
Rows(row_loc & ":" & row_loc).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Cells(row_loc, j + 1).Value = Cells(i, j + 1).Value
Cells(i, j + 1).Value = ""
row_loc = row_loc + 1
Next j
i = row_loc
row_loc = row_loc + 1
Loop
End Sub
why does this not work? Basically i have a list in a single cell i want to split strings ending in "sec" and ones that don't by copying them into different columns.
Sub test_if()
For i = 1 To 300
Cells(i, 2).Select
If Right(Cells(i, 2), 3) = "SEC" Then
ActiveCell.Select
Selection.Copy
Cells(i, 3).Select
ActiveSheet.Paste
End If
If Right(Cells(i, 2), 3) <> "SEC" Then
ActiveCell.Select
Selection.Copy
'Cells(i, 4).Select
ActiveCell.Offset(i - 1, 2).Select
ActiveSheet.Paste
End If
Next i
Cells(1, 1).Select
End Sub
Try this one:
Sub test_if()
Dim i As Integer
For i = 1 To 300
With Cells(i, 2)
If UCase(Right(.Value, 3)) = "SEC" Then
.Offset(, 1).Value = .Value
Else
.Offset(i - 1, 2).Value = .Value
End If
End With
Next i
End Sub
and also read, please, how to avoid using Select/Active statements