I have many rows having data in sheet 2 and I want the column name of the max of a row (i.e. from column name of B2 to AH2 inside if loop).
Sub shanaya()
Dim j As Integer
Dim i As Integer
Dim z As Integer
Dim x As Integer
z = 35
For i = 11 To 28
For j = 2 To 19
If Sheet8.Cells(j, 1) = Sheet1.Cells(i, 1) Then
Sheet1.Cells(i, 10) = Sheet8.Cells(j, z)
Max [(Sheet8.Cells(J,2)): (Sheet8.Cells(j,z))]
Sheet1.Cells(i,13) = column header of max function
End If
Next j
Next i
End Sub
The two key lines you need are along the lines of:
MaxVal = application.max(sheet8.range(sheet8.cells(j,2),sheet8.cells(j,z)))
sheet1.cells(i,13) = sheet8.cells(1,application.match(MaxVal,sheet8.rows(j)))
The first line finds the maximum value in the row. The second line returns the column header (presumably in row 1 as you're searching from row 2).
Related
I am trying to loop through the rows in column four of a table.
If the cell in the row has the text "Yes", I want to add 1 to X which I initiated as 0 at the start of the code.
My code does not increment and returns a zero or any other value that I initiate X to be.
Sub Row_Iter()
Dim otable As Table
Set otable = ActiveDocument.Tables(1)
Dim Row As Integer
Dim Col As Integer
Col = 4
Dim x As Integer
''Section 1
With otable.Columns(Col)
x = 0
For Row = 4 To Row = 7
If otable.Cell(Row, Col).Range.Text = "Yes" Then
x = x + 1
End If
Next Row
End With
End Sub
There are two problems with your code.
The first is that For Row = 4 To Row = 7 should be For Row = 4 To 7
The second is that If otable.Cells(Row, Col).Range.Text = "Yes" will never evaluate to True. This is because each cell contains a non-printing end of cell marker which consists of two characters. You can see this quite clearly by checking the length of an empty cell in the Immediate window, e.g.
?len(ActiveDocument.Tables(1).Cell(1,1).Range.Text)
So, your code should be:
Sub Row_Iter()
Dim otable As Table
Set otable = ActiveDocument.Tables(1)
Dim Row As Integer
Dim Col As Integer
Col = 4
Dim x As Integer
x = 0
For Row = 4 To 7
If left(otable.Cell(Row, Col).Range.Text, 3) = "Yes" Then
x = x + 1
End If
Next Row
End Sub
I have a spreadsheet with data as follows:
G H I J K L M N O P Q R S T U V W X Y Z AA AB AC AD ... etc.
2 1
3 2
4 4 8 12 16 20 24 28 32 36 40
5 8 16 24 32 40
That is, G2 = 1, G3 = 1 ... M4 = 28 and so on...
What I need help with is going through this range, which can be dynamic as people are entering data into this range when they need to change stuff. I need to iterate through the rows and then columns and, for each cell that has a value, I need to paste it into a different sheet in column D, 9 times for each cell.
That is, on the 2nd sheet, the data above would come across as:
Column
D
1
1
1
1
1
1
1
1
1
2
2
2
2
2
2
2
2
2
4
4
.. etc...
How do I iterate through each row, and then each column and then for each cell that has a value, copy that 9 times into column D on another sheet, and then for the next cell with a value, copy that BELOW what was pasted and so on?
Try the following. It assumes you want to go column by column iterating through all the populated cells in that column, repeating the value 9 times.
Option Explicit
Public Sub OutputRepeatedValues()
Dim arr()
Const DELIMITER As String = ","
Const NUMOFTIMES As Long = 9
With ThisWorkbook.Worksheets("Sheet1")
arr = .Range(.Range("G2"), .Range("G2").SpecialCells(xlLastCell)).Value
End With
Dim i As Long, j As Long, output As String
For i = LBound(arr, 2) To UBound(arr, 2) '<== iterate rows with a column, column by column
For j = LBound(arr, 1) To UBound(arr, 1)
If Not IsEmpty(arr(j, i)) Then output = output & Replicate(arr(j, i), NUMOFTIMES, DELIMITER)
Next j
Next i
output = Left$(output, Len(output) - 1)
ThisWorkbook.Worksheets("Sheet2").Range("B1").Resize(Len(output), 1) = Application.WorksheetFunction.Transpose(Split(output, DELIMITER))
End Sub
'Adapted from #this https://codereview.stackexchange.com/questions/159080/string-repeat-function-in-vba?utm_medium=organic&utm_source=google_rich_qa&utm_campaign=google_rich_qa
Public Function Replicate(ByVal RepeatString As String, ByVal NUMOFTIMES As Long, Optional ByVal DELIMITER As String = ",")
Dim s As String, c As Long, l As Long, i As Long
l = Len(RepeatString) + 1
c = l * NUMOFTIMES
s = Space$(c)
For i = 1 To c Step l
Mid(s, i, l) = RepeatString & DELIMITER
Next i
Replicate = s
End Function
Notes:
Test dataset laid out as shown below
I assume that you want to work with what ever data is down or the right of G2, including G2. In order to do this I am using SpecialCells(xlLastCell) to find the last used cell. I then construct a range with .Range(.Range("G2"), .Range("G2").SpecialCells(xlLastCell)), which in this case is $G$2:$Q$5, and read that into an array.
Assume that you indeed iterate rows with a column before moving onto next column as described in your question. I concatenate the populated cells values whilst at the same time calling the Replicate function described in 4).
I have hijacked, and adapted, a performant function by #this, to handle the string repeat. I have added in an optional argument for delimiter. A delimiter is added so I can later split on this to write out the results to individual cells within the target worksheet.
I split the string, output, on the delimiter, this creates an array of the repeated values, which I transpose, so I can write out to a column in the target sheet.
Example output:
Edit:
If instead you want to loop the rows, then columns, use with the above function the following instead:
Public Sub OutputRepeatedValues()
Dim arr()
Const DELIMITER As String = ","
Const NUMOFTIMES As Long = 9
With ThisWorkbook.Worksheets("Sheet1")
arr = .Range(.Range("G2"), .Range("G2").SpecialCells(xlLastCell)).Value
End With
Dim i As Long, j As Long, output As String
For i = LBound(arr, 1) To UBound(arr, 1) '<== iterate rows with a column, column by column
For j = LBound(arr, 2) To UBound(arr, 2)
If Not IsEmpty(arr(i, j)) Then output = output & Replicate(arr(i, j), NUMOFTIMES, DELIMITER)
Next j
Next i
output = Left$(output, Len(output) - 1)
ThisWorkbook.Worksheets("Sheet2").Range("B1").Resize(Len(output), 1) = Application.WorksheetFunction.Transpose(Split(output, DELIMITER))
End Sub
My vba is rusty but I think this (pseudo) code might help you.
def last_row as integer, last_col as integer, row as integer, col as integer, target as integer
'I like something like this to get the value but you have to know the largest column: Cells(Rows.Count, col_to_check).End(xlUp).Row
target = 1
for col = 7 to last_col '7 = G
for row = 2 to last_row
if(Not IsEmpty(Cells(row,col)) then
Range(Cells(target*9-8, 4), Cells(target*9, 4))= Cells(row,col)
target = target +1
end
next row
next col
this iterates through all cols and rows checks if there is a value and the copies it to a 9-cell range then iterates the target so it will point to the next 9 cells.
Column header for different sheet
iI have many rows having data in sheet 2 and iI want the column name of the max of a row (i.e. from column from column name of B2 to AH2 inside if loop).
Sub shanaya()
Dim j As Integer
Dim i As Integer
Dim z As Integer
Dim x As Integer
z = 35
For i = 11 To 28
For j = 2 To 19
If Sheet8.Cells(j, 1) = Sheet1.Cells(i, 1) Then
Sheet1.Cells(i, 10) = Sheet8.Cells(j, z)
Max [(Sheet8.Cells(J,2)): (Sheet8.Cells(j,z))]
Sheet1.Cells(i,13) = column header of max function
End If
Next j
Next i
End Sub
Using MATCH worksheet function will give you the column matching the MAX :
There is a +1 because your range start at col 2! ;)
Sub shanaya()
Dim j As Integer
Dim i As Integer
Dim z As Integer
Dim x As Integer
Dim ColOfMax As Integer
Dim RgToSearch As Range
z = 35
For i = 11 To 28
For j = 2 To 19
If Sheet8.Cells(j, 1) = Sheet1.Cells(i, 1) Then
Sheet1.Cells(i, 10) = Sheet8.Cells(j, z)
Set RgToSearch = Sheet8.Range(Sheet8.Cells(j, 2), Sheet8.Cells(j, z))
ColOfMax = Application.WorksheetFunction.Match(Application.WorksheetFunction.Max(RgToSearch), RgToSearch, 0) + 1
Sheet1.Cells(i, 13) = Sheet8.Cells(1, ColOfMax)
End If
Next j
Next i
End Sub
I am trying to get the below code to work. I would like to count blank cells for columns 1 to 50 in each worksheet. The below works, but it counts for the entire column. How can I change it to only count the first 10 rows in each column and if they are all blank, then change the column width to 1?
Many thanks
For j = 1 To 50
Blanks = WorksheetFunction.CountBlank(Worksheet.Columns(j))
If Blanks > 10 Then
ws.Columns(j).ColumnWidth = 1
End If
Next j
If you only want to check the first 10 rows you need to specify this in your CountBlank function. Your CountBlank(Worksheet.Columns(j)) is counting the entire column.
Also, your If Blanks > 10 Then will never evaluate to True as you only want to count 10 rows. I've changed that expression to If Blanks = 10.
Sub countTest()
Dim wks As Worksheet
Set wks = Worksheets("Sheet1")
For j = 1 To 50
Blanks = WorksheetFunction.CountBlank(wks.Range(Cells(1, j), Cells(10, j)))
If Blanks = 10 Then
wks.Columns(j).ColumnWidth = 1
End If
Next j
Set wks = Nothing
End Sub
Try something like this:
Dim i As Integer
Dim j As Integer
Dim k As Integer
For i = 1 To 50
k=0
For j = 1 to 10
If Activesheet.Cells(j,i).Value = "" Then
k=k+1
End If
Next j
If k = 10 Then
Activesheet.Columns(i).ColumnWidth = 1
End If
Next i
Let me know if there are any issues with it.
I am receiving a large file 500k+ lines but all the content is in column A. I need to run a macro that will transpose the data into matrix form but will only create a new row when it finds "KEY*" in the ActiveCell. For example:
| KEY 4759839 | asljhk | 35049 | | sklahksdjf|
| KEY 359 | skj | 487 |y| 2985789 |
The above data in my file would originally look like this in column A:
KEY 4759839
asljhk
35049
sklahksdjf
KEY 359
skj
487
y
2985789
Considerations:
Blank cells need to be transposed as well, so the macro cant stop based on emptyCell
The number of cells between KEY's is not constant so it actually needs to read the cell to know if it should create a new row
It can either stop based on say 20 empty cells in a row or prompt for a max row number
(Optional) It would be nice if there was some sort of visual indicator for the last item in a row so that its possible to tell if the last item(s) were blank cells
I searched around and found a macro that had the same general theme but it went based on every 6 lines and I did not know enough to try to modify it for my case. But in case it helps here it is:
Sub kTest()
Dim a, w(), i As Long, j As Long, c As Integer
a = Range([a1], [a500000].End(xlUp))
ReDim w(1 To UBound(a, 1), 1 To 6)
j = 1
For i = 1 To UBound(a, 1)
c = 1 + (i - 1) Mod 6: w(j, c) = a(i, 1)
If c = 6 Then j = j + 1
Next i
[c1].Resize(j, 6) = w
End Sub
I would greatly appreciate any help you can give me!
This works with the sample data you provided in your question - it outputs the result in a table starting in B1. It runs in less than one second for 500k rows on my machine.
Sub kTest()
Dim originalData As Variant
Dim result As Variant
Dim i As Long
Dim j As Long
Dim k As Long
Dim countKeys As Long
Dim countColumns As Long
Dim maxColumns As Long
originalData = Range([a1], [a500000].End(xlUp))
countKeys = 0
maxColumns = 0
'Calculate the number of lines and columns that will be required
For i = LBound(originalData, 1) To UBound(originalData, 1)
If Left(originalData(i, 1), 3) = "KEY" Then
countKeys = countKeys + 1
maxColumns = IIf(countColumns > maxColumns, countColumns, maxColumns)
countColumns = 1
Else
countColumns = countColumns + 1
End If
Next i
'Create the resulting array
ReDim result(1 To countKeys, 1 To maxColumns) As Variant
j = 0
k = 1
For i = LBound(originalData, 1) To UBound(originalData, 1)
If Left(originalData(i, 1), 3) = "KEY" Then
j = j + 1
k = 1
Else
k = k + 1
End If
result(j, k) = originalData(i, 1)
Next i
With ActiveSheet
.Cells(1, 2).Resize(UBound(result, 1), UBound(result, 2)) = result
End With
End Sub
Tested and works:
Sub test()
Row = 0
col = 1
'Find the last not empty cell by selecting the bottom cell and moving up
Max = Range("A650000").End(xlUp).Row 'Or whatever the last allowed row number is
'loop through the data
For i = 1 To Max
'Check if the left 3 characters of the cell are "KEY" and start a new row if they are
If (Left(Range("A" & i).Value, 3) = "KEY") Then
Row = Row + 1
col = 1
End If
Cells(Row, col).Value = Range("A" & i).Value
If (i > Row) Then
Range("A" & i).Value = ""
End If
col = col + 1
Next i
End Sub