This is the statement I am currently using. I need to find a way to populate the two rows I've inserted, using the value of the last populated cell before my new empty rows. How do I do this?
Sub Insert_Rows()
Dim r As Long, mcol As String, i As Long, s As Long, ncol As Long
' find last used cell in Column A
r = Cells(Rows.Count, "A").End(xlUp).Row
' get value of last used cell in column A
mcol = Cells(r, 1).Value
'find last used cell in Column B
s = Cells(Rows.Count, "B").End(xlUp).Row
' get value of last used cell in Column B
ncol = Cells(s, 1).Value
' insert rows by looping from bottom
For i = r To 2 Step -1
If Cells(i, 1).Value <> mcol Then
mcol = Cells(i, 1).Value
Rows(i + 1).Insert
Rows(i + 1).Insert
End If
Next i
End Sub
After you have inserted the rows you can use:
Rows(i + 1).Cells(1, 1).Value = "hi.." 'or
Rows(i + 1).Cells(1, 1).Value = mcol
Rows(i + 2).Cells(1, 1).Value = "there"
to insert values into the first cells of these rows.
Related
Ive been searching left and right but seem to only find bits and pieces. i'm unable to combine these into the solution i need.
My workbook has a list of items on the first sheet, the partnumbers in column A have to be searched for in Column A of a second sheet and if they exist there, those rows need to be copied to a third sheet.In steps i'm looking to do the following:
Column A of sheet1 (called "input") has several partnumbers.
After clicking CommandButton2 on sheet1, all partnumbers in Column A (starting in cell A5)should be searched for in Column A of sheet3 (called "partlists", starting in A2).
If found here, for all the respective rows where the partnumbers match: columns C to G("partlists") should be copied to sheet2("picklist") column A below the last row, the value in column E("picklist") has to be multiplied with the value in Column E("input") AND columns G to K("input") copied to the respective rows column G("Picklist")
If not found on "partlists", copy entire row from "input" to "picklist" below last row.
So far i've got the following code:
Sub InputPickMatch()
Dim LR As Long, i As Long, lngNextRow As Long, LookUpListInput As Range, LookUpListParts As Range
Set LookUpListInput = Sheets("Input").Range("A:A") 'lookup list Input
Set LookUpListParts = Sheets("Partlists").Range("A:A")
With Sheets("Input")
LR = .Cells(Rows.Count, "A").End(xlUp).Row 'last row
For i = 5 To LR
If IsError(Application.Match(.Cells(i, "A").Value, LookUpListParts, 0)) Then
.Range(Cells(i, "A").Address(), Cells(i, "D").Address()).Copy
Sheets("Picklist").Select
lngNextRow = Sheets("Picklist").Range("A" & Rows.Count).End(xlUp).Row + 1
Sheets("Picklist").Range("A" & lngNextRow).PasteSpecial _
Paste:=xlPasteValues
.Range(Cells(i, "F").Address(), Cells(i, "K").Address()).Copy
Sheets("Picklist").Range("E" & lngNextRow).PasteSpecial _
Paste:=xlPasteValues
End If
Next i
End With
With Sheets("Partlists")
LR = .Cells(Rows.Count, "A").End(xlUp).Row 'last row
For i = 3 To LR
If IsNumeric(Application.Match(.Cells(i, "A").Value, LookUpListInput, 0)) Then
.Range(Cells(i, "C").Address(), Cells(i, "G").Address()).Copy
Sheets("Picklist").Select
lngNextRow = Sheets("Picklist").Range("A" & Rows.Count).End(xlUp).Row + 1
Sheets("Picklist").Range("A" & lngNextRow).PasteSpecial _
Paste:=xlPasteValues
'Sheets("Picklist").Cells(lngNextRow, "E") = Sheets("Input").Cells(LookUpListInput, "E") * .Cells(i, "G") 'NOT WORKING: Multiply row from lookuplist column E with .Cells(i, "G")
'Sheets("Input").Range(Cells(LookUpList, "G").Address(), Cells(LookUpListInput, "K").Address()).Copy 'NOT WORKING: Copy row from lookuplist column G:K
'Sheets("Picklist").Range("F" & lngNextRow).PasteSpecial 'Paste Picklist column G
End If
Next i
End With
End Sub
It's working ok up to where i try to multiply and copy from the lookup list.
Hopefully someone can help
I got it guys
Sub InputToPicklist()
Dim LR As Long, i As Long, lngNextRow As Long, LookUpListInput As Range, LookUpListParts As Range
Dim Matchres As Variant
Set LookUpListInput = Sheets("Input").Range("A:A")
Set LookUpListParts = Sheets("Partlists").Range("A:A")
With Sheets("Input")
LR = .Cells(Rows.Count, "A").End(xlUp).Row
For i = 5 To LR
If IsError(Application.Match(.Cells(i, "A").Value, LookUpListParts, 0)) Then
lngNextRow = Sheets("Picklist").Range("A" & Rows.Count).End(xlUp).Row + 1
Sheets("Picklist").Range(Cells(lngNextRow, "A").Address(), Cells(lngNextRow, "D").Address()).Value = .Range(Cells(i, "A").Address(), Cells(i, "D").Address()).Value
Sheets("Picklist").Range(Cells(lngNextRow, "E").Address(), Cells(lngNextRow, "J").Address()).Value = .Range(Cells(i, "F").Address(), Cells(i, "K").Address()).Value
End If
Next i
End With
With Sheets("Partlists")
LR = .Cells(Rows.Count, "A").End(xlUp).Row 'last row
For i = 3 To LR
If IsNumeric(Application.Match(.Cells(i, "A").Value, LookUpListInput, 0)) Then
lngNextRow = Sheets("Picklist").Range("A" & Rows.Count).End(xlUp).Row + 1
Sheets("Picklist").Range(Cells(lngNextRow, "A").Address(), Cells(lngNextRow, "E").Address()).Value = .Range(Cells(i, "C").Address(), Cells(i, "G").Address()).Value
Matchres = Application.Match(.Cells(i, "A").Value, LookUpListInput, 0)
Sheets("Picklist").Cells(lngNextRow, "E") = Sheets("Input").Cells(Matchres, "F") * .Cells(i, "G") 'Multiply row from lookuplist column E with .Cells(i, "G")
Sheets("Picklist").Range(Cells(lngNextRow, "F").Address(), Cells(lngNextRow, "J").Address()).Value = Sheets("Input").Range(Cells(Matchres, "G").Address(), Cells(Matchres, "K").Address()).Value 'Copy row from lookuplist column G:K
End If
Next i
End With
Sheets("Input").Range("A5:K138").ClearContents
End Sub
First
Dim Matchres As Variant
and calling it
Matchres = Application.Match(.Cells(i, "A").Value, LookUpListInput, 0)
Does the trick
I would like to repeat ID number based on the "number" number. For example:
to
I have tried the following so far..
Sub MySub()
Do While B2 = n
CurrentSheet.Range("a1:c1").EntireRow.Resize(n).Insert
Loop
End Sub
It probably doesn't make much sense, as I am fairly new!
If you wanted to list the data in column D, you could use this
Sub x()
Dim r As Range
For Each r In Range("A2", Range("A" & Rows.Count).End(xlUp)) 'loop through A
Range("D" & Rows.Count).End(xlUp)(2).Resize(r.Offset(, 1).Value).Value = r.Value 'duplicate number of times in B
Next r
End Sub
If you want to insert into your existing data
Sub x()
Dim r As Long
For r = Range("A" & Rows.Count).End(xlUp).Row To 2 Step -1
If Cells(r, 2) > 1 Then
Cells(r + 1, 1).EntireRow.Resize(Cells(r, 2).Value - 1).Insert shift:=xlDown
Cells(r + 1, 1).Resize(Cells(r, 2).Value - 1) = Cells(r, 1).Value
End If
Next r
End Sub
I have a macro that creates a sheet full of data. I recently added new sheets so that unique values can go into each one. For example if a row contains "Pole Change Out" then that entire row is copy and pasted into the "Pole Change Out" sheet. there are 4 different sheets. My problem is, since some values are determined by a formula in vba, some values are not moving into the new sheet.
Sub copy_paste_based_on_cell_interior_rgb()
Dim LastRow As Long
Dim i As Long, j As Long
'Find the last used row in a Column: column A in this example
With Worksheets("Make-Ready")
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
'first row number where you need to paste values in Sheet1'
With Worksheets("Pole Change Out")
j = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
End With
For i = 1 To LastRow
With Worksheets("Make-Ready")
If .Cells(i, 27).Value = "Pole Change-Out" Then
.Rows(i).Copy Destination:=Worksheets("Pole Change Out").Range("A" & j)
j = j + 1
ElseIf .Cells(i, 27).Value = "New Midspan Pole" Then
.Rows(i).Copy Destination:=Worksheets("Midspan Poles").Range("A" & j)
j = j + 1
ElseIf .Cells(i, 104).Value = "Yes" Then
.Rows(i).Copy Destination:=Worksheets("Anchor Replacement").Range("A" & j)
j = j + 1
End If
End With
Next i
End Sub
As #scottCraner and the others pointed out. You are trying to use the first empty cell variable from one sheet on the other two sheets. The update to your code will automatically update the first blank cell for each sheet.
Sub copy_paste_based_on_cell_interior_rgb()
Dim LastRow As Long
Dim i As Long ', j As Long
'Find the last used row in a Column: column A in this example
With Worksheets("Make-Ready")
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
'first row number where you need to paste values in Sheet1'
'With Worksheets("Pole Change Out")
' j = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
'End With
For i = 1 To LastRow
With Worksheets("Make-Ready")
If .Cells(i, 27).Value = "Pole Change-Out" Then
.Rows(i).Copy Destination:=Worksheets("Pole Change Out").Cells(Rows.Count, 1).End(xlUp).Offset(1)
'j = j + 1
ElseIf .Cells(i, 27).Value = "New Midspan Pole" Then
.Rows(i).Copy Destination:=Worksheets("Midspan Poles").Cells(Rows.Count, 1).End(xlUp).Offset(1)
'j = j + 1
ElseIf .Cells(i, 104).Value = "Yes" Then
.Rows(i).Copy Destination:=Worksheets("Anchor Replacement").Cells(Rows.Count, 1).End(xlUp).Offset(1)
'j = j + 1
End If
End With
Next i
End Sub
I'm trying to copy a cell and the adjacent cell in a row and insert it as a new row with all the data to the right of this cell also copied over. My data looks like this after mining.
and im trying to get my data to look like this:
the image above is just one record but essentially its moving all the people and their corresponding position in the original row to a new row. In each row there are about 5 employees and their positions.
thanks
EDIT Attempted code for just 2 cols. 1 position. the idea was to create the empty rows and just copy the rest of the data with auto fill, then work from there
Sub TransposeInsertRows()
Dim rng As Range
Dim i As Long, j As Long, k As Long
Dim x As Long, y As Long
Set rng = Application.InputBox _
(Prompt:="Range Selection...", _
Title:="Enter the name col and pos col", Type:=8)
Application.ScreenUpdating = False
x = rng(1, 1).Column + 2
y = rng(1, rng.Columns.Count).Column
For i = rng(rng.Rows.Count, 1).Row To rng(1, 1).Row Step -1
If Cells(i, x) <> "" And Cells(i, x + 1) <> "" Then
k = Cells(i, x - 2).End(xlToRight).Column
If k > y Then k = y
For j = k To x + 1 Step -1
Cells(i + 1, 1).EntireRow.Insert
With Cells(i + 1, x - 2)
.Value = .Offset(-1, 0)
.Offset(0, 1) = .Offset(-1, 1)
.Offset(0, 2) = Cells(i, j)
End With
Cells(i, j).ClearContents
Next j
End If
Next i
Application.ScreenUpdating = True
End Sub
If there are always 5 people in each row then this should do it:
Sub foo()
LastRow = Sheet1.Cells(Sheet1.Rows.Count, "A").End(xlUp).Row
For i = 1 To LastRow 'loop through rows
For x = 1 To 10 Step 2 'loop through columns
LastRow2 = Sheet2.Cells(Sheet2.Rows.Count, "A").End(xlUp).Row + 1 'find the next free row on Sheet2
Sheet2.Cells(LastRow2, 1).Value = Sheet1.Cells(i, x).Value 'add Person Name to Sheet2
Sheet2.Cells(LastRow2, 2).Value = Sheet1.Cells(i, x + 1).Value 'add position to Sheet2
Sheet1.Range("K" & i & ":U" & i).Copy Destination:=Sheet2.Cells(LastRow2, 3) 'copy range from K to U to Sheet2
Next x
Next i
End Sub
enter image description hereThere are 2 sheets, Sheet1 and Sheet2.
Sheet1 contain 10 columns and 5 rows with data including blank.
The requirement is to copy the data from Sheet 1 and to put in another sheet Sheet 2, wherein only populate the cell which is not blank.
I get the run time error 1004 - Application or object defined error.
The code snippet is:-
Set wsht1 = ThisWorkbook.Worksheets("Sheet1")
Set wsht2 = Sheets("Sheet2")
finalrow = wsht1.Cells(wsht1.Rows.Count, 1).End(xlUp).Row
For i = 1 To finalrow
If wsht1.Cells(i, 1).Value <> " " Then
Range(Cells(i, 2), Cells(i, 2)).Copy
Worksheets("Sheet2").Select
wsht2.Range(Cells(1, i)).PasteSpecial Paste:=xlPasteFormats
End If
Next i
Can u help me in sorting this out?
You cannot define a range like that:
wsht2.Range(Cells(1, i))
you might use:
wsht2.Cells(1, i).PasteSpecial Paste:=xlPasteFormats
BTW: with this code you won't find empty cells:
If wsht1.Cells(i, 1).Value <> " " Then
you should use:
If wsht1.Cells(i, 1).Value <> "" Then
(the difference is a missing space between the quotes)
if you want to copy the values only and to make it with a loop I'd do the following:
Sub copying()
Set wsht1 = ThisWorkbook.Worksheets("Sheet1")
Set wsht2 = Sheets("Sheet2")
finalrow = wsht1.Cells(wsht1.Rows.Count, 1).End(xlUp).Row
For i = 1 To finalrow
If wsht1.Cells(i, 1).Value <> "" Then
For j = 1 To 5
wsht2.Cells(i, j).Value = wsht1.Cells(i, j).Value
Next j
End If
Next i
End Sub
If you only have 5 cells with data in Sheet 1 and only want those 5 rows copying to Sheet 2 use the following, similar to Shai's answer above with an extra counter for the rows in Sheet 2.
Sub copying()
Set wsht1 = ThisWorkbook.Worksheets("Sheet1")
Set wsht2 = Sheets("Sheet2")
finalrow = wsht1.Cells(wsht1.Rows.Count, 1).End(xlUp).Row
k = 1
For i = 1 To finalrow
If wsht1.Cells(i, 1).Value <> "" Then
For j = 1 To 5
wsht2.Cells(k, j).Value = wsht1.Cells(i, j).Value
Next j
k = k + 1
End If
Next i
End Sub
EDIT
As per your comment if you want to dynamically change j replace For j = 1 To 5 with
For j = 1 To wsht1.Cells(i, Columns.Count).End(xlToLeft).Column
The code below will copy only values in Column A (non-empty cells) from Sheet 1 to Sheet2:
Dim j As Long
Set wsht1 = ThisWorkbook.Worksheets("Sheet1")
Set wsht2 = Sheets("Sheet2")
finalrow = wsht1.Cells(wsht1.Rows.Count, 1).End(xlUp).Row
j = 1
For i = 1 To finalrow
With wsht1
' if you compare to empty string, you need to remove the space inside the quotes
If .Cells(i, 1).Value <> "" And .Cells(i, 1).Value <> " " Then
.Cells(i, 1).Copy ' since you are copying a single cell, there's no need to use a Range
wsht2.Range("A" & j).PasteSpecial Paste:=xlPasteValues, Paste:=xlPasteFormats
j = j + 1
End If
End With
Next i