I want a macro that can find top 3 values from my sample data between columns B to G, then copy and paste the value to another column in Column Q with the row it is from (within Column A and the row (Row A) it came from.
Eg.
D1 D2 D3
Seq RowA ColumnA
T1 10 20 30 After running macro: T1 D3 30
T2 11 22 2 T2 D2 22
T3 2 3 10 T4 D3 21
T4 6 19 21
Sub Top3()
Dim rng As Range
Dim i As Integer
Dim r As Integer
Range("B2").CurrentRegion.Copy
Range("Q2").PasteSpecial Paste:=xlPasteValues
Range("Q2").CurrentRegion.Sort Key1:=Range("B2"), Order1:=xlDescending
r = 5
For i = 1 To 3
Cells(r, "R") = Cells(r + 1, "A")
Cells(r, "S") = Cells(r + 1, "A")
r = r + 1
Next
Range("B2").CurrentRegion.Clear
Range("C2").Activate
End Sub
Target: All the Cells in the list of values
Target is a range that is 3 Columns x 4 Rows Target.Address = $B$2:$D$5
Target(1) refers to the first cell
Target(Target.Cells.Count) is the last cell
Target(x) is bound by its Columns
Target(4) is the same as saying Target.Cells(2, 1)
Target(x) is not bound by its Rows
The first column in Target is column B and the last row is 5. The next cell outside of the Target range is column B row 6
Target(Target.Cells.Count + 1).Address = $B$6
With this information it we can create a 1 dimensional array of Data that indices and values match that of Target. Using a 1D array makes it easy to reference cells in the Target range using built-in Excel WorksheetFunctions.
Sub GetTop3()
Dim Data
Dim Target As Range
Dim index As Long, x As Long
Set Target = Range("Offset(B1,1,0,Counta(B:B)-1,3)")
ReDim Data(1 To Target.Cells.Count)
For x = 1 To Target.Cells.Count
Data(x) = Target(x)
Next
For x = 2 To 4
index = WorksheetFunction.Match(WorksheetFunction.Max(Data), Data, 0)
With Target(index)
Cells(x, "R") = Rows(.Row).Columns("A")
Cells(x, "S") = Cells(1, .Column)
Cells(x, "T") = .Value
End With
Data(index) = vbNullString
Next
End Sub
This blog shows how to resize a range using the Offset WorksheetFunction: Advanced Excel Dynamic Named Ranges
Related
I have 2 sheets which I extract from the system. For sheet1(Data) contain multiple column and all the data inside. For sheet2(Get) I have 2 column, as per below. With reference column no 2 (ID) on sheet2(Get), I want to search this value in the sheet1(Data) then extract specific column value. I try to search online for example code and found this piece of code which extract all column value. But I only want to extract column with highlighted with yellow then extract this value into sheet2(Get). Can help me to modified this code?
Note: For sheet2(Get), all the data on both column A and B already prefilled so I would like to change Worksheet_SelectionChange into a normal sub then run this sub using macro. Possible?
Column C (Get sheet) should extract from Column B (Data sheet)
Column D (Get sheet) should extract from Column M (Data sheet)
Column E (Get sheet) should extract from Column J (Data sheet)
Column F (Get sheet) should extract from Column L (Data sheet)
Column G (Get sheet) should extract from Column C (Data sheet)
Column H (Get sheet) should extract from Column G (Data sheet)
sheet2(Get)
sheet1(Data)
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim k As Integer, i As Long, Str As Range
'row number
For i = 3 To Sheets("GetData").Range("a65536").End(3).Row
Set Str = Sheets("Data").Range("a:a").Find(Cells(i, 1).Value, , xlValues, xlWhole)
If Not Str Is Nothing Then
'column number
For k = 1 To 14
If k > 1 Then Sheets("GetData").Cells(i, k).Value = Sheets("Data").Cells(Str.Row, k).Value
Next k
Else
For k = 2 To 14
Sheets("GetData").Cells(i, k).Value = "Null"
Next k
End If
Next i
End Sub
Once you have the row you can copy like this:
Dim col As Long
'...
'...
col = 3
For Each e In Array(2, 3, 7, 10) 'columns to fetch
Sheets("GetData").Cells(i, col).Value = Str.EntireRow.Cells(e).Value
col = col + 1
Next
'...
'...
Public Sub fill_data()
Dim k As Integer, i As Long, Str As Range, col As Long, e As Variant
'row number
For i = 2 To Sheets("GetData").Range("B65536").End(3).Row
Set Str = Sheets("Data").Range("A:A").Find(Cells(i, 2).Value, , xlValues, xlWhole)
If Not Str Is Nothing Then 'if not empty
col = 3
For Each e In Array(13, 2, 10, 3, 5, 12, 9) 'columns to fetch
Sheets("GetData").Cells(i, col).Value = Str.EntireRow.Cells(e).Value
col = col + 1
Next
Else 'if empty
For col = 3 To 9
'Sheets("GetData").Cells(i, col).Interior.ColorIndex = 16 'change cell color OR
Sheets("GetData").Cells(i, col).Value = "NOTFOUND" 'change cell text
Next col
End If
Next i
End Sub
Thank you to Tim Williams for you help.
I'm trying to create a user interface for making timing charts.
I have a list of processes and how long each takes.
The user will enter numbers starting at 1 in the cells to the right
I'm trying to do the following:
For any row with a number copy the info from column B and F then paste it into row 39 + whatever number it finds.
This should create a list that is in the correct order in a chart.
I attempted to put together a program that loops through every row of every column in that number entry area.
Sub TimingChart()
Dim rng As Range
Dim cel As Range
Dim col As Range
'x is the variable for row adjustment to determine what cell to paste into
Dim x As Long
'a is the variable for column adjustments
Dim a As Long
Set rng = ThisWorkbook.Worksheets("Sheet1").Range("M4:AG33")
a = -11
'loop columns
For Each col In rng.Columns
'loop rows of that column
For Each cel In col.Cells
'skip cells with nothing in them
If cel.Value = "" Then
'any cell with a number copy the data in row B and row F and
'paste in the chart below the entry field starting in row 40
'the data should copy into row 39 + x putting the operations in order
Else
x = cel.Value
cel.Offset(a, 0).Copy cel.Offset(a, 39 + x)
cel.Offset(a + 4, 0).Copy cel.Offset(a + 4, 39 + x)
cel.Value.Copy cel.Offset(a - 1, 39 + x)
End If
Next
a = a - 1
Next col
End Sub
Edited to reflect removal of "range("
to get the numbers put this in A39 and copy down:
=IFERROR(SMALL($M$4:$AG$33,ROW(A1)),"")
To get the Actions, put this in B29 and copy down:
=IF(A39<>"",INDEX(B:B,AGGREGATE(15,7,ROW($M$4:$AG$33)/($M$4:$AG$33=A39),COUNTIF($A$39:A39,A39))),"")
To get the time, put this in F39 and copy down:
=IF(A39<>"",INDEX(F:F,MATCH(B39,$B:$B,0)),"")
So with data like:
using those formula we get:
If you really want vba then forget using offset and just refer to the column:
Sub TimingChart()
With ThisWorkbook.Worksheets("Sheet1")
Dim rng As Range
Set rng = .Range("M4:AG33")
'loop columns
Dim col As Range
For Each col In rng.Columns
'loop rows of that column
Dim cel As Range
For Each cel In col.Cells
'skip cells with nothing in them
If cel.Value = "" Then
'any cell with a number copy the data in row B and row F and
'paste in the chart below the entry field starting in row 40
'the data should copy into row 39 + x putting the operations in order
Else
'x is the variable for row adjustment to determine what cell to paste into
Dim x As Long
x = cel.Value
.Cells(cel.Row, 2).Copy .Cells(39 + x, 2)
.Cells(cel.Row, 6).Copy .Cells(39 + x, 6)
cel.Copy .Cells(39 + x, 1)
End If
Next cel
Next col
End With
End Sub
I have and excel document that looks like this:
and i want it to be like:
*comma (,) means that data are in different cells horizontally.
is there any vb macro or an expression to do it?
If all of the Rows have the same number of columns, then you can use INDEX, INT, COUNTA and MOD to break this down.
Column A:
=INDEX(Sheet1!$A$1:$D$2,1+INT((ROW()-1)/(COUNTA(Sheet1!$1:$1)-1)),1)
Column B:
=INDEX(Sheet1!$A$1:$D$2,1+INT((ROW()-1)/(COUNTA(Sheet1!$1:$1)-1)),2+MOD(ROW()-1,COUNTA(Sheet1!$1:$1)-1))
Where Sheet1!$A$1:$D$2 is the 'Input' range, and Sheet1!$1:$1 is any row in that range with a full row of data.
INDEX lets you get a specific row/column of a range. Our Range is Sheet1!$A$1:$D$2, and the Row is the same for both formulae:
1+INT((ROW()-1)/(COUNTA(Sheet1!$1:$1)-1)),
This will be 1 for n rows, 2 for the next n, etc, where n is the number of cells in a row minus the starter column (i.e. how many names per gender)
(INT removes the decimal part of a number, so INT(3/4) is INT(0.75), which is 0. COUNTA just counts the non-blank cells)
The difference between the two is the Column. In column A, we just want the first column, so Column is 1. In column B, we want the xth item after the first column, where x A) counts up by 1 each row and B) resets to 1 when we go from Male to Female (or beyond)
Now, the MOD function lets us do that fairly simply: MOD(0, 3) is 0, MOD(1, 3) is 1, MOD(2, 3) is 2, and MOD(3, 3) is back to 0. We just need to start out row count at 0 (subtract 1 from Row, and add it back outside the MOD) and remove the first column from the items-per-row (subtract 1 from the COUNTA, add 1 outside the MOD)
A straightforward solution would be to use Split
Sub TransferIt()
Const SEP = ","
Dim rg As Range
Dim vdat As Variant
Dim lDat As Variant
Dim i As Long, j As Long
Dim col As Collection
' Assumption data is in column A, adjust accordingly
Set rg = Range("A1:A4")
vdat = WorksheetFunction.Transpose(rg)
Set col = New Collection
For i = LBound(vdat) To UBound(vdat)
lDat = Split(vdat(i), SEP)
For j = LBound(lDat) + 1 To UBound(lDat)
' first field always contains female or male
col.Add lDat(LBound(lDat)) & SEP & lDat(j)
Next j
Next i
vdat = collectionToArray(col)
' Write data into column B
Range("B1").Resize(UBound(vdat) + 1) = WorksheetFunction.Transpose(vdat)
End Sub
' Source: http://www.iwebthereforeiam.com/iwebthereforeiam/2004/06/excel-vba-code-to-convert-coll.html
Function collectionToArray(c As Collection) As Variant()
Dim a() As Variant: ReDim a(0 To c.Count - 1)
Dim i As Integer
For i = 1 To c.Count
a(i - 1) = c.Item(i)
Next
collectionToArray = a
End Function
Before:
After:
Code:
Sub settupp()
Set s1 = Sheets("Sheet1")
Set s2 = Sheets("Sheet2")
s1.Activate
n = Cells(Rows.Count, 1).End(xlUp).Row
k = 1
For i = 1 To n
namee = Cells(i, 1).Value
For j = 2 To 4
numberr = Cells(i, j).Value
s2.Cells(k, 1) = namee
s2.Cells(k, 2) = numberr
k = k + 1
Next
Next
End Sub
I've been wraping my head around it for some time and just don't know how to approach this problem. My table consists of groups of data which I want to transpose from rows to columns. Every row has an index number in first column and all of the rows in one group have the same index.
1 a
1 b
1 c
1 d
1 e
1 f
1 g
1 h
2 as
2 bs
2 cs
5 ma
5 mb
5 mc
5 md
and I want my final result to be:
1 a b c d e f g h
2 as bs cs
5 ma mb mc md
is it possible to do this with formulas or do I have to do it in VBA?
You can also do this using a macro. Here is one method.
To enter this Macro (Sub), alt-F11 opens the Visual Basic Editor.
Ensure your project is highlighted in the Project Explorer window.
Then, from the top menu, select Insert/Module and
paste the code below into the window that opens.
To use this Macro (Sub), alt-F8 opens the macro dialog box. Select the macro by name, and RUN.
Option Explicit
Sub ReArrange()
Dim vSrc As Variant, rSrc As Range
Dim vRes As Variant, rRes As Range
Dim I As Long, J As Long, K As Long
Dim lColsCount As Long
Dim Col As Collection
'Upper left cell of results
Set rRes = Range("D1")
'Assume Data in A1:Bn with no labels
Set rSrc = Range("a1", Cells(Rows.Count, "A").End(xlUp)).Resize(columnsize:=2)
'Ensure Data sorted by index number
rSrc.Sort key1:=rSrc.Columns(1), order1:=xlAscending, key2:=rSrc.Columns(2), order2:=xlAscending, MatchCase:=False, _
Header:=xlNo
'Read Source data into array for faster processing
' compared with going back and forth to worksheet
vSrc = rSrc
'Compute Number of rows = unique count of index numbers
'Collection object can only have one entry per key
' otherwise it produces an error, which we skip
Set Col = New Collection
On Error Resume Next
For I = 1 To UBound(vSrc)
Col.Add Item:=vSrc(I, 1), Key:=CStr(vSrc(I, 1))
Next I
On Error GoTo 0
'Compute Maximum Number of columns in results
' Since there is one entry per Index entry, maximum number of
' columns will be equal to the Index that has the most lines
' So we iterate through each Index and check that.
For I = 1 To Col.Count
J = WorksheetFunction.CountIf(rSrc.Columns(1), Col(I))
lColsCount = IIf(J > lColsCount, J, lColsCount)
Next I
'Set up Results array
' Need to add one to the columns to account for the column with the Index labels
ReDim vRes(1 To Col.Count, 1 To lColsCount + 1)
'Now populate the results array
K = 1
For I = 1 To Col.Count
vRes(I, 1) = vSrc(K, 1)
J = 2
Do
vRes(I, J) = vSrc(K, 2)
J = J + 1: K = K + 1
If K > UBound(vSrc) Then Exit Do
Loop Until vSrc(K, 1) <> vRes(I, 1)
Next I
'Set the results range to be the same size as our array
Set rRes = rRes.Resize(rowsize:=UBound(vRes, 1), columnsize:=UBound(vRes, 2))
'Clear the results range and then copy the results array to it
rRes.EntireColumn.Clear
rRes = vRes
'Format the width. Could also format other parameters
rRes.EntireColumn.ColumnWidth = 10
End Sub
Yes its possible. You would need the following functions:
IF
MATCH
ISNA
INDEX
Assume you have the data in sheet 1 in columns A and B:
C1:
place the value "1" in cell C1
C2:
=C1+1
drag down as much as needed
D1
=MATCH(C1,A:A, 0)
Drag down as much as cell C2
E1
=MATCH(C1,A:A, 1)
Drag down as much as cell C2
Sheet 2:
Now place the following formulas in cell A1 in sheet2:
=IF(ISNA(Sheet1!$D1), "", IF(Sheet1!$D1="", "", IF(COLUMN()-1+Sheet1!$D1 <=Sheet1!$E1, INDEX(Sheet1!$B:$B, COLUMN()-1+Sheet1!$D1), "")))
Drag / Copy it to as many cells as needed:
Result:
Also I have an article on my blog about the INDEX function. It might help Excel INDEX Function.
You can also download the complete file here.
I am currently working on a problem where I have an Excel Spreadsheet that I would like to use a VBA macro on. Each of the following 3 rows are consecutive.
Name of Data
abc A1 B2 B4 C4 E2 F43 d4 V8 f9 k11 j20 … x
cde A2 B3 B12 C6 E9 F34 d6 V4 f13 k111 j209 … x
efg A3 B5 B7 C8 E11 F68 d19 V12 f91 k114 j2014 … x
…
Desired
abc A1 B2 B4 C4 E2 F43 d4 V8
abc f9 k11 j20 …
cde A2 B3 B12 C6 E9 F34 d6 V4
cde f13 k111 j209 …
efg A3 B5 B7 C8 E11 F68 d19 V12
efg f91 k114 j2014 …
I have the data name for each row and some rows can be hundreds of entries long spanning hundreds columns. So what I would like to do would be make my row length stop at 8 columns wide. I would hope that the macro can check through each row to see if the length is greater than 8, insert a row with the same data name and paste the next 8 columns, subtract it from the total columns and paste the next row, until it has reached the end of the first long row, and continue checking through all the rows. In essense, it saves a whole lot of time from counting up 8 columns wide, cut and pasting it in an inserted row below, preserving all other data. I'm new to this, so macro or VBA help is much appreciated.
Thanks,
John
The below macro will do exactly as you ask. It has some assumptions that I'll leave to you to fix, such as
Data is in sheet 1
Name column is always A, all data columns start from B
Everything starts in cell A1
This macro will run through every row and, for those rows with more than 9 data elements, it will create a new row and populate it with the previous rows Name and the remaining data rows. It will continue doing this until there is less than or equal to 8 data elements per row.
Since you have MANY rows you say, it would be a good idea to turn off screen updating, like so Application.ScreenUpdating = False before the for loop and turn it back on after the for loop.
Public Sub SplitRows()
Dim rowRange As Variant
Dim colCount As Integer
Dim lastColumn As Long
Dim rowCount As Integer
rowCount = Cells(Rows.Count, "A").End(xlUp).Row
Dim i As Integer
i = 1
Do While (i < rowCount)
lastColumn = Sheet1.Cells(i, Columns.Count).End(xlToLeft).Column
colCount = Sheet1.UsedRange.Columns.Count
rowRange = Range(Cells(i, 2), Cells(i, colCount))
'if the row has more than 9 values (name column + 8 data columns)
If Not lastColumn <= 8 Then
Dim x As Integer
'from column 2 (B, aka first data column) to last column
For x = 2 To colCount - 1
'if data is not empty AND x mod 8 is 1 (meaning 8 goes into x enough times to have a remainder of 1)
If Not IsEmpty(rowRange(1, x - 1)) And (x Mod 8) = 1 Then
Cells(i, 1).Offset(1).EntireRow.Insert 'insert new row below current row
rowCount = rowCount + 1 'update row count because we added a row
Sheet1.Cells(i + 1, 1).Value = Sheet1.Cells(i, 1).Value 'set first column name
Dim colsLeft As Integer
For colsLeft = x To colCount - 1
'take data value from col 9 to end and populate newly created row
Sheet1.Cells(i + 1, colsLeft - 7).Value = rowRange(1, colsLeft)
Sheet1.Cells(i, colsLeft + 1).Value = "" 'set data value from col 9 on and set to empty
Next
Exit For 'exit loop, weve done all we need to and must now check the newly populated row
End If
Next
End If
i = i + 1
Loop
End Sub
Here is a before and after of the results:
BEFORE
AFTER
Argh, I tried somewhat along this lines, but I have to go to work. Maybe it is helpful as a starting point.
Public Sub Test()
Dim mastercell As Range
Set mastercell = ActiveWorkbook.Worksheets(1).Cells(1, 1)
Dim masterValue As String
masterValue = mastercell.Value
If GetCount(masterValue) > 8 Then
Dim tempvalue As String
tempvalue = masterValue
Dim Rowcount As Integer
Dim ColCount As Integer
Rowcount = mastercell.Row
ColCount = mastercell.Column + 1
Do While GetCount(tempvalue) > 8
Dim WriteValue As String
WriteValue = GetFirstEight(tempvalue)
ActiveWorkbook.Worksheets(1).Cells(Rowcount, ColCount).Value = WriteValue
ColCount = ColCount + 1
tempvalue = Replace(tempvalue, WriteValue, 0, 1)
Loop
End If
End Sub
Private Function GetCount(str As String) As Integer
Dim Splitter As String
Splitter = " "
Dim SplitArray As Variant
SplitArray = Split(str)
GetCount = UBound(SplitArray)
End Function
Private Function GetFirstEight(str As String) As String
Dim i As Integer
Dim NewString As String
Dim SplitArray() As String
SplitArray = Split(str)
For i = 0 To 7
NewString = NewString & SplitArray(i) & " "
Next
GetFirstEight = NewString
End Function