How to retrieve values from predefined row and a column range (Incremental) to text boxes (Incremental) such that for example value of cell “J4” populate in "textbox1" and its column heading in "Label1" , value of cell “k4” populate in "textbox2" and its column heading in "Label2" and so on ............. value of cell“BG4” populate in "textbox50" and its column heading in "Label50".
I have tried the followings
Private Sub CommandButton1_Click()
Dim i As Long, lastrow As Long
Dim ws As Worksheet
Dim fcolumn As Long
Dim lcolumn As Long
Set ws = Worksheets("md")
lastrow = ws.Cells.Find(What:="*",
SearchOrder:=xlRows,SearchDirection:=xlPrevious, LookIn:=xlValues).Row + 1
fcolumn = 9
lcolumn = 50
For i = 2 To lastrow
fcolumn = fcolumn + 1
If ws.Cells(i, "A").Value = Val(Me.TextBox_orderno) Then
If Sheets("md").Cells(i, fcolumn).Value <> 0 Then
Me.Label1 = ws.Cells(2, fcolumn)
Me.TextBox1 = Sheets("md").Cells(i, fcolumn).Value
End If
If Sheets("md").Cells(i, fcolumn).Value <> 0 Then
Me.Label2 = ws.Cells(2, fcolumn)
Me.TextBox1 = Sheets("md").Cells(i, fcolumn).Value
End If
Next
End Sub
I'm still not sure exactly what you are doing, but see if this helps you along. It should at least show you how to dynamically refer to the names of controls which alter only in the number at the end.
Private Sub CommandButton1_Click()
Dim i As Long, lastrow As Long
Dim ws As Worksheet
Dim fcolumn As Long
Dim lcolumn As Long
Set ws = Worksheets("md")
lastrow = ws.Cells.Find(What:="*", SearchOrder:=xlRows, SearchDirection:=xlPrevious, LookIn:=xlValues).Row + 1
fcolumn = 9
lcolumn = 50
For i = 2 To lastrow
fcolumn = fcolumn + 1
If ws.Cells(i, "A").Value = Val(Me.Controls("TextBox" & i - 1)) Then
If Sheets("md").Cells(i, fcolumn).Value <> 0 Then
Me.Controls("Label" & i - 1).Value = ws.Cells(2, fcolumn)
Me.Controls("Textbox" & i - 1).Value = Sheets("md").Cells(i, fcolumn).Value
End If
End If
Next
End Sub
Related
I have a spreadsheet that has values that looks similar to below :
Is there any possible way to create VBA to join all the separate data together for each ID and Class into one row? So that the ending result would look like below?
Sub JoinRowsData()
Dim lastRow As Long, i As Long, j As Long, k As Long
Application.ScreenUpdating = False
lastRow = Range("C" & Rows.Count).End(xlUp).Row
For i = 2 To lastRow
For j = i + 1 To lastRow
If Cells(i, 2) = Cells(j, 2) Then
For k = 5 To 10
If (Cells(i, k) = "" And Cells(j, k) <> "") Then
Cells(i, k) = Cells(j, k)
End If
Next
End If
Next
Next
Application.ScreenUpdating = True
End Sub
The following will do it. See the comments for an explanation how it works. It uses arrays to process the data which is much faster than process cells directly.
Option Explicit
Public Sub JoinRowsData()
Dim ws As Worksheet ' define worksheet
Set ws = ThisWorkbook.Worksheets("Sheet1")
Dim LastRow As Long ' get last used row in worksheet
LastRow = GetLastUsed(xlByRows, ws)
Dim LastCol As Long ' get last used column in worksheet
LastCol = GetLastUsed(xlByColumns, ws)
' Read data into an array for faster processing
Dim Data() As Variant
Data = ws.Range("A1", ws.Cells(LastRow, LastCol)).Value2
' define an output array with the same size
Dim Output() As Variant
ReDim Output(1 To UBound(Data, 1), 1 To UBound(Data, 2))
Dim outRow As Long ' output row index
Dim iRow As Long
For iRow = 1 To LastRow ' loop through all rows in data
' if column 1 contains data it is a new output row
If Data(iRow, 1) <> vbNullString Then
outRow = outRow + 1
End If
' loop through all columns in a data row
Dim iCol As Long
For iCol = 1 To LastCol
If Data(iRow, iCol) <> vbNullString Then ' check if current cell has data
If Output(outRow, iCol) <> vbNullString Then
' add a line break if there is already data in the output cell
Output(outRow, iCol) = Output(outRow, iCol) & vbLf
End If
' add the data to the output cell
Output(outRow, iCol) = Output(outRow, iCol) & Data(iRow, iCol)
End If
Next iCol
Next iRow
' write all the output data from the array back to the cells
ws.Range("A1", ws.Cells(LastRow, LastCol)).Value2 = Output
End Sub
' find last used row or column in worksheet
Public Function GetLastUsed(ByVal RowCol As XlSearchOrder, ByVal InWorksheet As Worksheet) As Long
With InWorksheet
If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
Dim LastCell As Range
Set LastCell = .Cells.Find(What:="*", _
After:=.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=RowCol, _
SearchDirection:=xlPrevious, _
MatchCase:=False)
If RowCol = xlByRows Then
GetLastUsed = LastCell.Row
Else
GetLastUsed = LastCell.Column
End If
Else
GetLastUsed = 1
End If
End With
End Function
Hi I am trying to update cell values on all rows until the row number changes. Here is my code:
Sub MyLoop()
Dim i As Integer
Dim var As String
Dim LastRow As Long
LastRow = Range("A" & Rows.Count).End(xlUp).Row
i = 1
var = Cells(i, 4).Value
For i = 1 To LastRow
If Range("A" & i).Value = "1" Then
Cells(i, 2).Value = var
End If
var = Cells(i, 4).Value
Next i
End Sub
I have attached before and after images of how it should look once routine has been ran. Basically Loop through all rows and in column A is the number changes store the value in column D and paste it into column B until the row number changes.
Before:
After:
Kind Regards
Is it really when the number changes or when the word in Column D changes?
Columns("D:D").Cut Destination:=Columns("B:B")
Range("B1:B" & Cells(Rows.Count, "A").End(xlUp).Row).SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
Range("B1:B" & Cells(Rows.Count, "A").End(xlUp).Row).Value = Range("B1:B" & Cells(Rows.Count, "A").End(xlUp).Row).Value
Sub MyLoop()
Dim i As Integer
Dim var As String
Dim LastRow As Long
LastRow = Range("A" & Rows.Count).End(xlUp).Row
For i = 1 To LastRow
IF Cells(i, 4).Value<>"" Then 'Get new value from column 4
var = Cells(i, 4).Value
End If
Cells(i, 2).Value = var 'Assign value to column 2
Next i
End Sub
Fill Column
A Quick Fix
Sub MyLoop()
Dim LastRow As Long
Dim i As Long
Dim A As Variant
Dim D As Variant
LastRow = Cells(Rows.Count, 1).End(xlUp).Row
For i = 1 To LastRow
If Cells(i, 1).Value <> A Then
A = Cells(i, 1).Value
D = Cells(i, 4).Value
End If
Cells(i, 2).Value = D
Next i
End Sub
A More Flexible Solution
Adjust the values in the constants section.
Option Explicit
Sub fillColumn()
' Define constants.
Const wsName As String = "Sheet1"
Const ColumnsAddress As String = "A:D"
Const LookupCol As Long = 1
Const CriteriaCol As Long = 4
Const ResultCol As Long = 2
Const FirstRow As Long = 2
' Define Source Range.
Dim rng As Range
With ThisWorkbook.Worksheets(wsName).Columns(ColumnsAddress)
Set rng = .Columns(LookupCol).Resize(.Rows.Count - FirstRow + 1) _
.Offset(FirstRow - 1).Find( _
What:="*", _
LookIn:=xlFormulas, _
SearchDirection:=xlPrevious)
If rng Is Nothing Then
Exit Sub
End If
Set rng = .Resize(rng.Row - FirstRow + 1).Offset(FirstRow - 1)
End With
' Write values from Source Range to Data Array.
Dim Data As Variant: Data = rng.Value
' Define Result Array.
Dim Result As Variant: ReDim Result(1 To UBound(Data, 1), 1 To 1)
' Declare additional variables.
Dim cLookup As Variant ' Current Lookup Value
Dim cCriteria As Variant ' Current Criteria Value
Dim i As Long ' Rows Counter
' Write values from Data Array to Result Array.
For i = 1 To UBound(Data, 1)
If Data(i, LookupCol) <> cLookup Then
cLookup = Data(i, LookupCol)
cCriteria = Data(i, CriteriaCol)
End If
Result(i, 1) = cCriteria
Next i
' Write from Result Array to Destination Column Range.
rng.Columns(ResultCol).Value = Result
End Sub
I want to remove duplicates based on the text in Column I and sum the values in Column C, the data in the other columns doesn't matter.
I do not want a pivot table and I am aware they are the preferred option for this type of thing.
An example of what I'd like to achieve:
I found VBA code and tried to modify it. It doesn't delete all the lines.
Sub Sum_and_Dedupe()
With Worksheets("data")
'deal with the block of data radiating out from A1
With .Cells(1, 1).CurrentRegion
'step off the header and make one column wider
With .Resize(.Rows.Count - 1, .Columns.Count + 1).Offset(1, 0)
.Columns(.Columns.Count).Formula = "=sumifs(c:c, i:i, i2)"
.Columns(3) = .Columns(.Columns.Count).Value
.Columns(.Columns.Count).Delete
End With
'remove duplicates
.RemoveDuplicates Columns:=Array(9), Header:=xlYes
End With
.UsedRange
End With
End Sub
This should be an answer to your question.
However, code might require adaptation if the range in which you look becomes very long.
Option Explicit
Sub test()
Dim wb As Workbook
Dim ws As Worksheet
Dim LastRow As Long, LastCol As Long, a As Double, i As Long
Dim Rng As Range
Dim Cell As Variant, Estimate As Variant
Set wb = ThisWorkbook
Set ws = wb.Sheets(1)
LastRow = ws.Cells(ws.Rows.Count, "I").End(xlUp).Row
LastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
Set Rng = ws.Range(ws.Cells(2, 9), ws.Cells(LastRow, 9))
For Each Cell In Rng
i = 0
a = 0
For Each Estimate In Rng
If Estimate.Value = Cell.Value Then
i = i + 1 'Count nr of intances
a = a + ws.Cells(Estimate.Row, 3).Value 'sum booking value
If i > 1 Then
ws.Rows(Estimate.Row).Delete
i = 1
LastRow = LastRow - 1
End If
End If
Next Estimate
ws.Cells(Cell.Row, 3).Value = a 'Enter sum in booked this week
Next Cell
End Sub
You'll either need to change your current sheet name to data, or change the first two lines of this code to fit your needs. sh = the data sheet that you showed us. osh = an output sheet that this code will generate. Note also if column C or I move you can update the positions easily by changing colBooked and colEstimate. If you have more than a thousand unique estimate entries then make the array number larger than 999.
Sub summariseEstimates()
Dim sh As String: sh = "data"
Dim osh As String: osh = "summary"
Dim colBooked As Integer: colBooked = 3
Dim colEstimate As Integer: colEstimate = 9
Dim myArray(999) As String
Dim shCheck As Worksheet
Dim output As Worksheet
Dim lastRow As Long
Dim a As Integer: a = 0
Dim b As Integer
Dim r As Long 'row anchor
Dim i As Integer 'sheets
'Build summary array:
With Worksheets(sh)
lastRow = .Cells.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row
For r = 2 To lastRow
If r = 2 Then 'first entry
myArray(a) = .Cells(r, colEstimate) & "," & .Cells(r, colBooked)
Else
For b = 0 To a
If VBA.LCase(VBA.Replace(.Cells(r, colEstimate), " ", "")) = VBA.LCase(VBA.Replace(VBA.Split(myArray(b), ",")(0), " ", "")) Then 'match
myArray(b) = VBA.Split(myArray(b), ",")(0) & "," & VBA.Split(myArray(b), ",")(1) + .Cells(r, colBooked)
Exit For
End If
Next b
If b = a + 1 Then 'completed loop = no match, create new array item:
a = a + 1
myArray(a) = .Cells(r, colEstimate) & "," & .Cells(r, colBooked)
End If
End If
Next r
End With
'Create summary sheet:
On Error Resume Next
Set shCheck = Worksheets(osh)
If Err.Number <> 0 Then
On Error GoTo 0
Set output = Worksheets.Add(After:=Worksheets(sh))
output.Name = osh
Err.Clear
Else
On Error GoTo 0
If MsgBox("*" & osh & "* sheet already exists. Proceed to delete and recreate?", vbOKCancel, "Summary") = vbCancel Then
Exit Sub
Else
Application.DisplayAlerts = False
Worksheets(osh).Delete
Set output = Worksheets.Add(After:=Worksheets(sh))
output.Name = osh
End If
End If
'Output to summary sheet:
With Worksheets(osh)
.Cells(1, 1).Value = "ESTIMATE"
.Cells(1, 2).Value = "BOOKED THIS WEEK"
For b = 0 To a
.Cells(b + 2, 1).Value = VBA.Split(myArray(b), ",")(0)
.Cells(b + 2, 2).Value = VBA.Split(myArray(b), ",")(1)
Next b
.Columns("A:B").AutoFit
End With
End Sub
I'm trying to get my code to insert four rows every time it finds a difference in the cell below. If A5-55 = 1, A56-80 = 2, A81 - 100 = 3 I want the code to see that 56 isn't equal to 55 and insert 4 rows, then continue down the A column until there are no more values.
I keep getting an error from Excel,
can not complete task. Resources error
And then a runtime 1004 insert method of range class failed, and the debugger highlights the code for inserting rows
This is what my data looks like:
Worksheets("HR-Calc").Activate
For lRow = Cells(Cells.Rows.Count, "A").End(xlUp).Row To 6 Step -1
If Cells(lRow, "A") <> Cells(lRow - 1, "A") Then
Rows(lRow).EntireRow.Insert
Rows(lRow).EntireRow.Insert
Rows(lRow).EntireRow.Insert
Rows(lRow).EntireRow.Insert
End If
Next lRow
A neater way would be to use an autofilter on the table
(The code assumes that column A is a sorted integer ID - as seems to be the case from the image)
Sub InsertRowsBetweenIncrements()
Dim ws As Worksheet: Set ws = Worksheets("HR-Calc")
Dim HeaderRow As Long: HeaderRow = 4
Application.ScreenUpdating = False
Dim LastRow As Long: LastRow = ws.Columns(1).Find("*", _
SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Dim LastCol As Long: LastCol = ws.Cells.Find("*", _
SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
Dim Tbl As Range: Set Tbl = ws.Range(Cells(HeaderRow, 1), Cells(LastRow, LastCol))
Dim i As Long, j As Long
For i = ws.Cells(LastRow, 1).Value To 1 Step -1
Tbl.AutoFilter Field:=1, Criteria1:=i
j = Tbl.SpecialCells(xlCellTypeVisible).SpecialCells(xlCellTypeLastCell).Row
Tbl.AutoFilter
If j <> HeaderRow And j < LastRow Then _
ws.Rows(j + 1 & ":" & j + 4).Insert Shift:=xlDown
Next i
Application.ScreenUpdating = True
End Sub
If you want a less-clunky was (as you mentioned), I would default to using arrays to increase speed. Give the code below a try and see what you think. This assumes your data starts in row 6 (if not, change the value of "offset" to the final row before the data in question starts). If you want to change how many rows you insert in the future, just change the value of rows_to_insert to the desired number.
Sub insertrows()
Dim check_col() As Variant
Dim rng As Range
Dim lcell As Range
Dim i As Long
Dim rows_to_insert As Long
Dim rows_added As Long
Dim offset As Long
Dim insert_cell As Long
Worksheets("HR-Calc").Activate
lrow = Cells(Cells.Rows.Count, "A").End(xlUp).Row
Set lcell = Cells(lrow, 1)
Set rng = Range("A6", lcell)
check_col = rng
rows_to_insert = 4
rows_added = 0
offset = 5
rows_added = 0
For i = 1 To (UBound(check_col, 1) - 1)
If check_col(i, 1) <> check_col(i + 1, 1) Then
check_col(i, 1) = i + rows_added + offset
rows_added = rows_added + rows_to_insert
Else: check_col(i, 1) = VBnllstring
End If
Next i
check_col(UBound(check_col, 1), 1) = vbNullString
rows_to_insert = rows_to_insert - 1
For i = 1 To UBound(check_col, 1)
If check_col(i, 1) <> vbNullString Then
insert_cell = check_col(i, 1) + 1
Range(Cells(insert_cell, 1), Cells(insert_cell + rows_to_insert, 1)).EntireRow.Select
Range(Cells(insert_cell, 1), Cells(insert_cell + rows_to_insert, 1)).EntireRow.Insert
End If
Next i
End Sub
The code below is what I have so far. But for some reason it says I have a next soureRow without for. Any help would be great. I'm trying to get this script to loop through sheets 4 to 10 and if the row has a bg colour of yellow or red and sheet one doesnt have a matching value. to copy the row to the bottom of sheet 1.
target = "Sheet1"
For allSheets = 4 To 10
lastTargetRow = Sheets(target).Range("A" & Rows.Count).End(xlUp).Row
Sheets(allSheets).Activate
lastCurrentRow = Sheets(allSheets).Range("A" & Rows.Count).End(xlUp).Row
For sourceRow = 2 To lastCurrentRow
If ActiveSheet.Cells(sourceRow, "B").Interior.Color = Yellow Then
For checkRow = 2 To lastTargetRow
If ActiveSheet.Cells(sourceRow, "B").Value <> Sheets(target).Cells(checkRow, "B").Value Then
nRow = Sheets(target).Range("A" & Rows.Count).End(xlUp).Row + 1
For lCol = 1 To 26 'Copy entire row by looping through 6 columns
Sheets(target).Cells(nRow, lCol).Value = Sheets(allSheets).Cells(sourceRow, lCol).Value
Next lCol
End If
Next checkRow
If ActiveSheet.Cells(sourceRow, "B").Interior.Color = Red Then
For checkRow2 = 2 To lastTargetRow
If ActiveSheet.Cells(sourceRow, "B").Value <> Sheets(target).Cells(checkRow, "B").Value Then
nRow = Sheets(target).Range("A" & Rows.Count).End(xlUp).Row + 1
For lCol = 1 To 26 'Copy entire row by looping through 6 columns
Sheets(target).Cells(nRow, lCol).Value = Sheets(allSheets).Cells(sourceRow, lCol).Value
Next lCol
End If
Next checkRow2
End If
Next sourceRow
Next allSheets
This might get you closer:
Sub Tester()
Const TARGET As String = "Sheet1"
Dim shtTarget As Worksheet, allSheets As Long, nextTargetRow As Long
Dim shtTmp As Worksheet, lastCurrentRow As Long, sourceRow As Long
Dim clr As Long, f As Range, bCell As Range
Dim myYellow As Long '<<EDIT
myYellow = RGB(255, 235, 156)
Set shtTarget = Sheets(TARGET)
nextTargetRow = shtTarget.Cells(Rows.Count, "A").End(xlUp).Row + 1
For allSheets = 4 To 10
Set shtTmp = Sheets(allSheets)
lastCurrentRow = shtTmp.Cells(Rows.Count, "A").End(xlUp).Row
For sourceRow = 2 To lastCurrentRow
Set bCell = shtTmp.Cells(sourceRow, "B")
clr = bCell.Interior.Color 'get the color
'is yellow or red?
If clr = myYellow Or clr = vbRed Then
'look in colB on Target sheet for the value from source
Set f = shtTarget.Columns(2).Find(bCell.Value, lookat:=xlWhole)
If f Is Nothing Then
'ColB value is not already listed
shtTarget.Cells(nextTargetRow, 1).Resize(1, 26).Value = _
shtTmp.Cells(sourceRow, 1).Resize(1, 26).Value
nextTargetRow = nextTargetRow + 1
End If
End If
Next sourceRow
Next allSheets
End Sub