Below is my initial excel sheet
Below is what my output should be
My approach:
Get the first value from column A
Get the Offset(0,1) of column A (results in B1)
Get the number of records from column B till the first empty cell (results in 3)
Copy value of A1 to the cells (number of records - 1) below A1
Loop for all the 3 values in column A
I have implemented till I get the addresses of the cells with values in column A. Below is my code.
Dim currentRow As Integer
Dim element As Variant
Dim totalRows As String
Dim offsetrow As String
Dim offsetcell As Variant
totalRows = Range("A" & ActiveSheet.Rows.Count).End(xlUp).row
MsgBox (totalRows)
For currentRow = 1 To totalRows
If (IsEmpty(Cells(currentRow, 1).Value)) Then
Else
Cells(currentRow, 1).Select
offsetcell = ActiveCell.Offset(0, 1).Address
'Do the rest
End If
Next
End Sub
Any help is appreciated
You could optimize this by using arrays but this is the basic idea:
Dim i As Long
For i = 1 To ActiveSheet.UsedRange.Rows.Count
If Cells(i + 1, 1).Value = "" And Cells(i, 1).Value <> "" And Cells(i + 1, 2).Value <> "" Then
Cells(i + 1, 1).Value = Cells(i, 1).Value
End If
Next
This is my work around to achieve the desired output. This might not be the most efficient way of doing this. Anyways it works :).
Sub Button1_Click()
Dim currentRow As Integer
Dim totalrows As String
Dim offsetrow As Integer
Dim i As Integer
Dim row As Integer
totalrows = Range("A" & ActiveSheet.Rows.Count).End(xlUp).row
For currentRow = 1 To totalrows
If (IsEmpty(Cells(currentRow, 1).Value)) Then
Else
Cells(currentRow, 1).Select
offsetrow = ActiveCell.Offset(0, 1).row
row = offsetrow
i = 1
Do While (Cells(row, 2).Value <> "")
i = i + 1
row = row + 1
Cells((row - 1), 1).Value = Cells(currentRow, 1).Value
Loop
End If
Next
End Sub
Hope this helps to anyone come across the same issue.
Just an alternate solution:
To accurately determine the number of rows for your range:
Lastrow = Cells.Find("*", [A1], , , xlByRows, xlPrevious).Row
An alternate method for your problem:
Manual
select range in column a,
go to blanks (ctrl+g),
press =, up arrow. Now hold ctrl+Enter
Copy/paste as values...
Here's a code snippet to do this:
Lastrow = Cells.Find("*", [A1], , , xlByRows, xlPrevious).Row
Range("A1:A" & Lastrow).Select
Selection.SpecialCells(xlCellTypeBlanks).Select
Selection.FormulaR1C1 = "=R[-1]C"
Range("A1:A" & Lastrow).Value = Range("A1:A" & Lastrow).Value
Finish off by looping through column B and deleting A values where B is blank.
Hope this helps.
Related
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 trying to write a code where I want to look select range from Start to End in column A then fill the selected range in Column B with '1'. But my code only fill up bottom parts and missed out top parts. Refer to this photo. How do i make sure it go through every row and when it encounter Start, it will look for nearest End and fill up column B?
Sub Select()
Dim LastRowA As Long, i As Long
Dim findrow As Long, findrow2 As Long
With ThisWorkbook.Worksheets("Sheet1")
LastRowA = .Cells(.Rows.Count, "A").End(xlUp).Row
For i = 1 To LastRowA
findrow = Range("A:A").Find("Start", Range("A1")).Row
findrow2 = Range("A:A").Find("End", Range("A" & findrow)).Row
Range("A" & findrow & ":A" & findrow2).Offset(0, 1).Value = "1"
Next i
End With
End Sub
This will find Start, loop through until it finds End. Tested and working as requested.
Sub Select()
Dim LastRowA, i As Long
With ThisWorkbook.Worksheets("Sheet1")
LastRowA = .Cells(.Rows.Count, "A").End(xlUp).Row
For i = 1 To LastRowA
If .Cells(i, 1) = "Start" Then
Do Until .Cells(i, 1) = "End"
.Cells(i, 2).Value = 1
i = i + 1
Loop
.Cells(i, 2).Value = 1
End If
Next i
End With
End Sub
Find is a precarious beast to use in VBA. It would be far simpler to just loop through the cells, keeping track of whether or not you're between Start and End:
Sub Select()
Dim LastRowA As Long, i As Long, b As Boolean
With ThisWorkbook.Worksheets("Sheet1")
LastRowA = .Cells(.Rows.Count, "A").End(xlUp).Row
For i = 1 To LastRowA
If .Cells(i, 1).Value = "Start" Then
b = True
.Cells(i, 2).Value = 1
ElseIf .Cells(i, 1).Value = "End" Then
b = False
.Cells(i, 2).Value = 1
ElseIf b Then
.Cells(i, 2).Value = 1
End If
Next i
End With
End Sub
I have one sheet of data where I need to extract the values from multiple columns and assign them a value. Column A is a string where column B is the assigned value. Columns C and D are vlookups based on column A and they will need the assigned value from column B as well. Please see the screenshots. I would need to compile a list on a separate sheet. Ideally column A would have the data from columns A, C and D from the other sheet and column B would have the assigned values. Only caveat is I need to exclude any row that has #N/A
Any macro that may work would be very helpful!
Code I was using
Sub Life_Saver_Button()
Dim lastrow As Long, erow As Long
Set S1 = Worksheets("Sheet1")
Set S2 = Worksheets("Sheet2")
lastrow = ThisWorkbook.Sheets("S1").Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To lastrow
S1.Cells(i, 1).Copy
erow = ThisWorkbook.Sheets("S2").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
ThisWorkbook.Sheets("S1").Paste Destination:=ThisWorkbook.Sheets("S2").Cells(erow, 1)
ThisWorkbook.Sheets("S1").Cells(i, 2).Copy
ThisWorkbook.Sheets("S1").Paste Destination:=ThisWorkbook.Sheets("S2").Cells(erow, 2)
ThisWorkbook.Sheets("S1").Cells(i, 3).Copy
ThisWorkbook.Sheets("S1").Paste Destination:=ThisWorkbook.Sheets("S2").Cells(erow, 1)
ThisWorkbook.Sheets("S1").Cells(i, 4).Copy
ThisWorkbook.Sheets("S1").Paste Destination:=ThisWorkbook.Sheets("S2").Cells(erow, 2)
ThisWorkbook.Sheets("S1").Cells(i, 5).Copy
ThisWorkbook.Sheets("S1").Paste Destination:=ThisWorkbook.Sheets("S2").Cells(erow, 1)
ThisWorkbook.Sheets("S1").Cells(i, 5).Copy
ThisWorkbook.Sheets("S1").Paste Destination:=ThisWorkbook.Sheets("S2").Cells(erow, 2)
Next i
Application.CutCopyMode = False
ThisWorkbook.Sheets("S2").Columns().AutoFit
Range("A1").Select
End Sub
Try:
Option Explicit
Sub test1()
Dim LastrowA As Long, Lastrow As Long, cell As Range, Code As Long
Dim Desc As String
With ThisWorkbook.Worksheets("Sheet1")
LastrowA = .Cells(.Rows.Count, "A").End(xlUp).Row
For Each cell In .Range("A1:D" & LastrowA)
If Not IsError(cell.Value) = True And Not IsNumeric(cell.Value) = True Then
Desc = cell.Value
Code = .Range("B" & cell.Row).Value
Lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
If LastrowA = Lastrow Then
.Range("A" & Lastrow + 2).Value = Desc
.Range("B" & Lastrow + 2).Value = Code
Else
.Range("A" & Lastrow + 1).Value = Desc
.Range("B" & Lastrow + 1).Value = Code
End If
End If
Next
End With
End Sub
Results:
I have the code below which takes a table of data, removes most of the columns and any rows where the value in column C is zero, and finally sorts by column C.
What I need to be able to do next is find the row where the values in column C change from positive to negative and insert 5 blank rows.
I can find other code examples which loop through the values to perform a number of tasks but I just need insert rows where the values change from positive to negative.
Sub FormatData()
Dim wsData As Worksheet
Dim FirstRow As Integer
Dim LastRow As Integer
Dim LastRow2 As Integer
Dim lrow As Integer
Set wsData = Worksheets("Data")
FirstRow = wsData.Range("C2").Row
LastRow = wsData.Range("A" & Rows.Count).End(xlUp).Row
Columns("C:Y").Select
Selection.Delete Shift:=xlToLeft
Columns("D:F").Select
Selection.Delete Shift:=xlToLeft
wsData.Range("C2:C" & LastRow).Select
For lrow = LastRow To FirstRow Step -1
Set workrange = Cells(lrow, 3)
If workrange.Value = "0" _
Then workrange.EntireRow.Delete
Next lrow
LastRow2 = wsData.Range("C" & Rows.Count).End(xlUp).Row
Range("A2:C" & LastRow2).Sort Key1:=Range("C2:C" & LastRow2), Order1:=xlDescending, Header:=xlNo
End Sub
You can add something like the following loop to the end of your sub after your sorting code:
FirstRow = wsData.Range("C2").Row
LastRow = wsData.Range("C" & Rows.Count).End(xlUp).Row
For lrow = FirstRow To LastRow
If wsData.Cells(lrow, 3).Value >= 0 And wsData.Cells(lrow + 1, 3).Value <= 0 Then
For x = 1 To 5
wsData.Rows(lrow + 1).Insert shift:=xlShiftDown
Next x
Exit For
End If
Next lrow
Using Excel 2010, I'm trying to create a script that concatenates two text columns (A and B) from Sheet1 and pastes the result in column A of Sheet2.
The workbook uses an external datasource for loading both columns, so the number of rows is not fixed.
I've tried the following code, but not working. variable lRow is not taking any value.
Sub Concat()
Sheets("Sheet1").Select
Dim lRow As Long
lRow = Range("A" & Rows.count).End(xlUp).Row
For i = 2 To lRow
ActiveWorkbook.Sheets("Sheet2").Cells(i, 1) = Cells(i, 1) & Cells(i, 2)
Next i
End Sub
What am I doing wrong. Thanks for helping!
As to what are you doing wrong, I suggest you use
Sub Concat()
Sheets("Sheet1").Select
Dim lRow As Long, i As Long
Dim rng As Range
Set rng = Range("A" & Rows.Count).End(xlUp)
Debug.Print rng.Address(External:=True)
lRow = rng.Row
For i = 2 To lRow
ActiveWorkbook.Sheets("Sheet2").Cells(i, 1) = Cells(i, 1) & Cells(i, 2)
Next i
End Sub
to see what is going on. I tried exactly what you used and it worked for me (Excel 2010).
Specifying what does "variable lRow is not taking any value" mean would help.
You could also try alternatively
Sub Concat2()
Sheets("Sheet1").Select
Dim lRow As Long, i As Long
Dim rng As Range
Set rng = Range("A2").End(xlDown)
Debug.Print rng.Address(External:=True)
lRow = rng.Row
For i = 2 To lRow
ActiveWorkbook.Sheets("Sheet2").Cells(i, 1) = Cells(i, 1) & Cells(i, 2)
Next i
End Sub
which should give the same result if yo do not have blank cells in the middle of the source column A.
I would advise getting out of the .Select method of XL VBA programming in favor of direct addressing that will not leave you hanging with errors.
Sub Concat()
Dim i As Long, lRow As Long
With Sheets("Sheet1")
lRow = .Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To lRow
Sheets("Sheet2").Cells(i, 1) = .Cells(i, 1) & .Cells(i, 2)
Next i
End With
End Sub
Note the periods (aka . or full stop) that prefix .Cells and .Range. These tell .Cells and .Range that they belong to the worksheet referenced in the With ... End With block; in this example that would be Sheets("Sheet1").
If you have a lot of rows to string together you would be better off creating an array of the values from Sheet1 and processing the concatenation in memory. Split off the concatenated values and return them to Sheet2.
Sub concat2()
Dim c As Long, rws As Long, vCOLab As Variant
With Sheets("Sheet1")
rws = .Range("A2:A" & .Cells(Rows.Count, 1).End(xlUp).Row).Rows.Count
vCOLab = .Range("A2").Resize(rws, 3)
For c = LBound(vCOLab, 1) To UBound(vCOLab, 1)
'Debug.Print vCOLab(c, 1) & vCOLab(c, 2)
vCOLab(c, 3) = vCOLab(c, 1) & vCOLab(c, 2)
Next c
End With
Sheets("Sheet2").Range("A2").Resize(rws, 1) = Application.Index(vCOLab, , 3)
End Sub
When interacting with a worksheet, bulk operations will beat a loop every time; the only question is by how much.