Let's say I have a table: the columns correspond to years (such as 1999, 2000, ..., 2020) and the rows are countries.
How can I make Excel display only the top 10 values of each column and set other countries values =0 ?
I assume the first cell ("Country") is the cell A1.
Open your sheet.
Alt + F11
Insert => Module
Paste this code:
Sub leave_top_10_on_every_column()
Dim iLastRow As Long
Dim iLastCol As Long
Dim i As Long
Dim j As Long
Dim dblTop10 As Double
iLastRow = ActiveSheet.Cells(1, 1).End(xlDown).Row
iLastCol = ActiveSheet.Cells(1, 1).End(xlToRight).Column
For i = 2 To iLastCol
dblTop10 = WorksheetFunction.Large(ActiveSheet.Cells(1, i).EntireColumn, 10)
For j = 2 To iLastRow
If ActiveSheet.Cells(j, i) < dblTop10 Then ActiveSheet.Cells(j, i) = 0
Next
Next
End Sub
Put the mouse pointer somewhere in the middle of this code and hit F5 to run the code.
Related
I have a file.xls with three sheets.
Sheet1, 2 columns, 3000 rows;
ColumnA: location_id
ColumnB: location_label
Sheet2, 2 columns, 5000 rows;
ColumnA: location_id
ColumnB: screen_id
Sheet3, 2 columns, 6000 rows;
ColumnA: screen_id
ColumnB: screen_name
how to group data into a new sheet4 with the following syntax (view image);
ColumnA: Location_label
ColumnB: screen_name
location_id get location_label name in sheet 1, location_id get screen_id value in sheet2, screen_id get screen_name value in sheet3 and in sheet4 result with location_label and screen_name.
#EDIT QUESTION WITH USE VLOOKUP;
I tried to use VLOOKUP but from error after the first id number 19 of sheet2...i have used this '
=VLOOKUP(Sheet2!A2;Sheet1!A2:B2133;2;)
i get
RED
GREEN
YELLOW
#N/D
#N/D
Public Sub pair_value()
'here i tried to deconstruct the code so it is easy to follow
'this type of paring would work much better with access
'you can use this code to start
Dim h1 As Integer 'row count in sheet1
Dim h2 As Integer 'row count in sheet2
Dim h3 As Integer 'row count in sheet3
Dim h4 As Integer 'row count in sheet4
Dim ar1() As Variant
Dim ar2() As Variant
Dim ar3() As Variant
Dim ar4() As Variant
Dim pair1() As Variant
Dim range1 As Range
Dim range2 As Range
Dim range3 As Range
Dim i As Integer
Dim j As Integer
'---------------------------------------------------
'This exercise would be so much easier using ACCESS
'---------------------------------------------------
'number of rows in each sheets
h1 = Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Row
h2 = Worksheets(2).Cells(Rows.Count, 1).End(xlUp).Row
h3 = Worksheets(3).Cells(Rows.Count, 1).End(xlUp).Row
h4 = Worksheets(4).Cells(Rows.Count, 1).End(xlUp).Row
'define arrays
ReDim ar1(h1, 2)
ReDim ar2(h2, 2)
ReDim ar3(h3, 2)
ReDim pair1(h2, 2)
'set range
Set range1 = Worksheets(1).Range(Worksheets(1).Cells(2, 1), Worksheets(1).Cells(h1, 2))
Set range2 = Worksheets(2).Range(Worksheets(2).Cells(2, 1), Worksheets(2).Cells(h2, 2))
Set range3 = Worksheets(3).Range(Worksheets(3).Cells(1, 1), Worksheets(3).Cells(h3, 2))
'load range into arrays
ar1 = range1
ar2 = range2
ar3 = range3
'associate location_label to screen_id using location_id as primary key
For i = 1 To UBound(ar2)
For j = 1 To UBound(ar1)
If ar2(i, 1) = ar1(j, 1) Then
'load screen id + label in pair1 in pair1 array
pair1(i, 1) = ar2(i, 2)
pair1(i, 2) = ar1(j, 2)
End If
Next j
Next i
'associate location_label to screen_name using screen_id as primary key
For i = 1 To UBound(ar3)
For j = 1 To UBound(pair1)
If ar3(i, 1) = pair1(j, 1) Then
Debug.Print j
'past results in sheets(4)
h4 = Worksheets(4).Cells(Rows.Count, 1).End(xlUp).Row
Worksheets(4).Cells(h4 + 1, 1).Value = pair1(j, 2)
Worksheets(4).Cells(h4 + 1, 2).Value = ar3(i, 2)
End If
Next j
Next i
End Sub
Well I'm not the best with Excel and I do not fully understand what you want as an end result. But here is my guess what I think is the problem.
I suspect that in sheet 4 you type you code in A2 and use your mouse to drag the formula to the bottom of the column. If this is the case, your formula will not be exactly the same in every cell, because your matrix in the formula will change while you drag your mouse. Therefore the error #N/D
To prevent your matrix from changing while dragging your mouse you should use '$'.
So your formula would be:
=VLOOKUP(Sheet2!A2;Sheet1!$A$2:$B$2133;2;)
Possibly a tip:
I see you have the same columns in more than 1 sheet. You can put all you data in 1 sheet and then use filters to select the data you want. See this article.
I have a set of x names (in row 4) with corresponding dates (row 3) (the combination of name and date is unique).
I would like to copy the unique name and date, and then paste it x times (where x is the total number of names) in a different sheet.
I would like the code to loop through all names and dates and paste them within column A,B in a new sheet. Where column A has heading name and column B has heading date.
Initial data:
After Code:
What I have attempted so far - i can't seem to get the paste correct
Sub Test()
Dim o As Variant
Dim CountC_Range As Range
Dim cel_3 As Range
Dim MyRange As Range
'count the number of different engagement areas
Worksheets("Sheet8").Activate
Range("B4").Select
Set CountC_Range = Range("B4", Selection.End(xlToRight))
'Set the letter k as number of engagements as we'll use this later
o = WorksheetFunction.CountA(CountC_Range) - "1"
Worksheets("sheet9").Activate
Range("A1").Select
MyRange = Range("Selection.End(xlDown) + 1", "Selection.End(xlDown) + o + 1")
For Each cel_3 In Worksheets("Sheet8").Range("4:4")
If cel_3.Value <> "" Then
MyRange = cel_3.Value
End If
Next cel_3
End Sub
There are plenty of ways to do it, but having this input:
The code below will provide this:
Sub TestMe()
With Worksheets("Source")
Dim k As Long
k = .Range("A4").End(xlToRight).Column
End With
With Worksheets("Target")
Dim i As Long, ii As Long
Dim currentRow As Long
For i = 1 To k
For ii = 1 To k
currentRow = currentRow + 1
.Cells(currentRow, "A") = Worksheets("Source").Cells(3, i)
.Cells(currentRow, "B") = Worksheets("Source").Cells(4, i)
Next
Next
End With
End Sub
Dependencies:
Name the input worksheet "Source"
Name the output worksheet "Target"
A must read - How to avoid using Select in Excel VBA
I want to copy & paste every 10 rows, 10 times from column A to column B and so on continuing until the end of column A.
This is an example of macro I've tried:
Sub cpydble()
Dim j As Long
Dim i As Long
Dim lRow As Long
lRow = Cells(Rows.Count, 1).End(xlUp).row
For i = 1 To lRow Step 10
For j = 1 To 100 Step 10
Cells(i, 1).Resize(10).Copy Destination:=Cells(j, 2)
Next j
Next i
End Sub
I'm a beginner with VBA and hope you can help with this - thanks in advance.
This is my current result:
You could use:
For i = 1 To lRow Step 10
Range("B" & i & ":B" & i + 9).Value = Range("A1:A10").Value
Next i
Note that with the above code, the last iteration will go below the last row in column A should it not be a multiple of 10.
Starting j at 1 every time is probably what's messing stuff up. Just find the next open cell for every loop.
Sub cpydbl()
Dim i As Long, j As Long
Dim lRow As Long
lRow = Cells(Rows.Count, 1).End(xlUp).Row
For i = 1 To lRow Step 10
For j = 1 To 10
Cells(i, 1).Resize(10).Copy Cells(Rows.Count, 2).End(xlUp).Offset(1, 0)
Next j
Next i
Cells(1, 2).Delete xlShiftUp
End Sub
The Offset starts the copy at row 2, so I delete the empty first cell at the end to move everything up.
Fully flexibilized code
In addition to #DickKusleika 's fine code, I demonstrate a fully flexibilized approach using a data array where you can define alternative block size, number of repetitions and start row via constants.
Option Explicit ' declaration head of your code module
Sub copyBlocks()
Const SIZE& = 10, REPETITIONS& = 10, STARTROW& = 1 ' define block size, repetions and start row
Dim ws As Worksheet, i&, j&, k&, n&, v ' declare variables
Set ws = ThisWorkbook.Worksheets("MySheet") ' << change to your sheet name
n = ws.Range("A" & ws.Rows.Count).End(xlUp).Row ' find last row number in column A
n = ((n + SIZE) \ SIZE) * SIZE ' round up to full block size of 10 rows
ws.Range("B:B") = "" ' clear column B
k = STARTROW ' start row of 1st block series
For i = STARTROW To n Step SIZE ' if STARTROW = 1 For i=1, 11, 21, 31 ... To n
v = ws.Range("A" & i).Resize(SIZE) ' get next data block (10 rows)
For j = 1 To REPETITIONS ' write eg. 10 data blocks to column B
ws.Range("B" & (k + (j - 1) * SIZE)).Resize(SIZE) = v
Next j
k = k + SIZE * REPETITIONS ' get start row of next block series
Next i
End Sub
Notes
Declare your variables (and their types) and force yourself to do so by stating Option Explicit in the declaration head of your code module; the ampersand sign & is short for e.g. Dim i As Long. v and all not explicitly declared variables default to Variant.
Always use fully qualified range references, otherwise values default to the active sheet which might result in wrong values.
Variable n finds the last row number in column A and rounds it up to the full block size of 10 rows.
You can easily assign range values to a variant 2-dimensional array in one code line, e.g. via v = ws.Range("A1:E1234") or v = ws.Range("A1:A17").Value. Further hint Each member of this array could be addressed by row and column indices. Note that data field arrays getting values from worksheet ranges are 1-based, so the first value would be addressed as v(1,1).
As stated above, I'm trying to write a program that looks at the last 5 columns of every row in Sheet2 and copies that row if any of the cells in those last 5 columns are empty, then pastes the row into a new sheet Sheet3. I've been searching and found some helpful links but I keep getting an "Object required" error. I have a feeling I forgot something simple but I'm not getting anywhere. This is my 2nd day attempting macros, I appreciate any help!
Sub missingDataCopy()
Dim startColumn As Integer
Dim startRow As Integer
Dim totalRows As Integer
Dim totalColumns As Integer
Dim currentColumn As Integer
Dim currentRow As Integer
Dim shouldCopyRow As Boolean
Dim j As Long
startColumn = 7
totalColumns = 11
startRow = 1
j = 1
totalRows = Sheet2.Cells(Rows.Count, startColumn).End(xlUp).Row
For currentRow = totalRows To startRow Step -1
shouldCopyRow = False
For currentColumn = startColumn To totalColumns
If IsEmpty(Sheet2.Cells(currentRow, currentColumn)) Then
shouldCopyRow = True
Exit For
End If
Next
If shouldCopyRow Then
Sheet2.Cells(currentRow, currentColumn).EntireRow.Copy Destination:=Worksheets("Sheet3").Range("A" & j)
j = j + 1
End If
The error you are getting indicates that there is not Sheet in your Excel file with the CodeName Sheet2. Have a look at the following illustration to see the distinction between the Name of a sheet (which you see in the tab) and the CodeName:
If you wish to code with the CodeName then you must change it in the VBE as shown above. Alternatively you can also use the Name of the sheet. But then your line should read:
totalRows = ThisWorkbook.Worksheets("Sheet1").Cells(ThisWorkbook.Worksheets("Sheet1").Rows.Count, startColumn).End(xlUp).Row
Because the name of the sheet in the above example is Sheet1.
I am very new to VBA and trying to consolidate an excel file with 0.2 million rows.
My excel format is
You can see that so much duplicated data there. I want to make the whole sheet have only 4 columns by appending other columns data as the headers are same.
For example :
Data in the columns F2-I2 will go to A4 - D4
F3 - I3 will go to A5 - D5
similarly
K2 - N2 will go to A6 - D6
K3 - N3 will go to A7 - D7
And follows
I want to write a VBA macro and by running the macro it should make the excel have only 4 columns by appending all other columns data.
Can someone please help me achieving that.
NOTE : After doing that my excel will have around 1 million rows. So i am looking for a solution with good performance.
I think this only can be solved by looping through the blocks, the columns and the rows which probably takes some time if you have a million values.
To increase performance disable screenUpdating and to ensure that the macro does not crash include DoEvents() in the loop.
Please note that the maximum number of rows in Excel is 1'048'576
Sub moveValues()
Application.ScreenUpdating = False
Dim i As Integer
Dim j As Integer
Dim k As Long
Dim row As Long
Dim col As Integer
Dim lastRowTarget As Long
Dim lastRowSource As Long
Dim wks As Worksheet
Set wks = Sheets("Sheet1")
For i = 6 To 16 Step 5
lastRowSource = wks.Cells(Rows.Count, Chr(64 + i)).End(xlUp).row
lastRowTarget = wks.Cells(Rows.Count, "A").End(xlUp).row
col = 1
For j = i To i + 3
For k = 2 To lastRowSource
wks.Cells(lastRowTarget + k - 1, col) = wks.Cells(k, j)
DoEvents
Next k
col = col + 1
Next j
Next i
Application.ScreenUpdating = True
End Sub