I am trying to copy 3 entire rows below a cell which includes a text.
I've already wrote this but there are some issues that I can't solve due to being a beginner of VBA.
Option Explicit
Private Sub SearchandInsertRows()
Dim lRow As Long, iRow As Long
With Worksheets("Main_Page")
lRow = .Cells(.Rows.Count, "A").End(xlup).Row
For iRow = lRow to 1 Step -1
If .Cells(iRow, "A").Value = Range("D5") Then
.Rows(iRow).Resize(3).Insert
End if
Next iRow
End With
End Sub
I want excel to read the entire A column and find the cell which has same text with cell D5 (Text is BillNumber). Then add 3 blank rows above that. Lastly copy the three cells below BillNumber and paste it to recently created 3 blank rows.
Here is screenshot to make it more understandable.
Here is one way, remove the MsgBox lines, they are for debugging.
Sub insertPaste()
Dim D5Val As String, wk As Workbook, fVal As Range
Set wk = ThisWorkbook
With wk.Sheets("Sheet1")
'Value from D5
D5Val = .Range("D5").Value
'Find D5 on column A
Set fVal = .Columns("A:A").Find(D5Val, , xlValues, , xlNext)
If fVal Is Nothing Then
'Not found
MsgBox "Not Found"
Else
'Found
MsgBox "Found at: " & fVal.Address
'Insert 3 Cells on top of the cell found with the data from the 3 cells below
.Range("A" & (fVal.Row + 1) & ":A" & (fVal.Row + 3)).Copy
.Range("A" & fVal.Row & ":A" & (fVal.Row + 2)).Insert Shift:=xlDown
Application.CutCopyMode = False
End If
End With
End Sub
Copy Cells Below Text Above Text
The Code
Private Sub SearchandInsertRows()
Dim lRow As Long, iRow As Long
With Worksheets("Main_Page")
lRow = .Cells(.Rows.Count, "A").End(xlUp).Row
For iRow = lRow To 1 Step -1
If .Cells(iRow, "A").Value = .Range("D6") Then
.Rows(iRow).Resize(3).Insert
.Rows(iRow + 3 & ":" & iRow + 5).Copy .Rows(iRow)
End If
Next iRow
End With
End Sub
Related
I'm entering a value in the last blank cell (as I can't do the last row in a column) due to other data being there. I was to add the sum of all the above cells to each column.
The number of columns is variable as is the number of names
I've been able to add the relevant formula but I can't get it to copy across in the same way my other code did.
This is the line with the error, to copy to the last used column, everything else works except this bit.
Range("O" & nextfree).AutoFill Range("O" & nextfree, Cells("O" & nextfree, lastcolumn))
I get a run type error 13, Type mis-match.
The full code is here
Sub addrow()
'Checks the number of users then adds them to the active sheet section
Dim rowsToAdd As Integer
Dim lastcolumn As Long
Dim lastRow As Long
Dim ws As Worksheet, ws1 As Worksheet
Set ws = ThisWorkbook.Worksheets("Refs")
Set w1 = ThisWorkbook.Worksheets("Active events")
With ws
lastRow = Sheets("Refs").Cells(.Rows.Count, "A").End(xlUp).Row
lastcolumn = Sheets("Active events").Cells.Find("*", searchorder:=xlByColumns, SearchDirection:=xlPrevious).Column
MsgBox lastRow - 1
MsgBox lastcolumn
End With
With ws1
Rows("5:5").Resize(lastRow - 1).Insert Shift:=xlDown ' minus 2 to account for header row and also existing text in row 4
End With
Worksheets("Refs").Range("A2:A" & lastRow).Copy Worksheets("Active events").Range("M4")
Range("O4:O" & lastRow + 2).Formula = "=SUMIF($C$14:$C$5032,$M4,O$14:O$5032)"
Range("O4:O" & lastRow + 2).AutoFill Range("O4", Cells(lastRow + 2, lastcolumn))
'Find the next blank cell in the names range and adds totals and the sum value to all columns
nextfree = Range("M4:M" & Rows.Count).Cells.SpecialCells(xlCellTypeBlanks).Row
Range("M" & nextfree).Value = "Total"
Range("O" & nextfree).Value = "=SUM(O4:O" & nextfree - 1 & ")"
'Problem code here
Range("O" & nextfree).AutoFill Range("O" & nextfree, Cells("O" & nextfree, lastcolumn))
End Sub
I am attempting to copy Columns D & E from the last row to the next row. Currently I am getting a Compile Error: Type Mismatch. I've been fighting this all day with different ways of going about it. Any help would be appreciated.
Sub PTB()
Dim LastRow As Long
With ActiveSheet
LastRow = .Cells(.Rows.Count, "D").End(xlUp).Row
End With
Dim lastCellCoords As String: lastCellCoords = "D" & LastRow & ":E" & LastRow
Dim firstEmptyRow As Integer: firstEmptyRow = LastRow + 1
Dim firstEmptyCoords As String: firstEmptyCoords = "D" & firstEmptyRow & ":E" & firstEmptyRow
If Not LastRow Is Nothing Then
' Now Copy the range:
Worksheets("Survey").Range(lastCellCoords).Copy
' And paste to first empty row
Worksheets("Survey").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
Application.CutCopyMode = False
Else
MsgBox ("There is no data in specified range")
End If
End Sub
I am very new to VBA and trying to update the code below to look for a value within a cell rather than ActiveCell. Specifically, I want to find the row below a cell with a value of "B." (e.g.), copy the 3 rows below, and paste+insert those 3 rows directly beneath the copied 3 rows. Effectively, I am trying to get my VBA button to work without asking users to first click into a specific cell. My current code, based on ActiveCell, is working well as long as you are in the correct cell. Any insight would be helpful.
Sub CommandButton2_Click()
Dim NextRow As Long
Dim I As Long
With Range(ActiveCell.Offset(rowOffset:=2), ActiveCell.Offset(rowOffset:=0))
NextRow = .Row + .Rows.Count
Rows(NextRow & ":" & NextRow + .Rows.Count * (1) - 1).Insert Shift:=xlDown
.EntireRow.Copy Rows(NextRow & ":" & NextRow + .Rows.Count * (1) - 1)
.Resize(.Rows.Count * (1 + 1)).Sort key1:=.Cells(1, 1)
End With
End Sub
Please, test the next updated code. It will require the string/text of the cell you need to identify (in an InputBox). For testing reason, I used the string "testSearch". Please, put it in the cell of A:A to be identified and test it. Then, you can use whatever string you need...
Sub testTFindCellFromString()
Dim NextRow As Long, I As Long, strSearch As String
Dim sh As Worksheet, actCell As Range, rng As Range
strSearch = InputBox("Please, write the string from the cell to be identified", _
"Searching string", "testSearch")
If strSearch = "" Then Exit Sub
Set sh = ActiveSheet
Set rng = sh.Range("A1:A" & sh.Range("A" & Cells.Rows.Count).End(xlUp).Row)
Set actCell = testFindActivate("testSearch", rng)
If actCell Is Nothing Then Exit Sub
With Range(actCell.Offset(2, 0), actCell.Offset(0, 0))
NextRow = .Row + .Rows.Count
Rows(NextRow & ":" & NextRow + .Rows.Count * (1) - 1).Insert Shift:=xlDown
.EntireRow.Copy Rows(NextRow & ":" & NextRow + .Rows.Count * (1) - 1)
.Resize(.Rows.Count * (1 + 1)).Sort key1:=.Cells(1, 1)
End With
Debug.Print actCell.Address
End Sub
Private Function testFindActivate(strSearch As String, rng As Range) As Range
Dim actCell As Range
Set actCell = rng.Find(What:=strSearch)
If actCell Is Nothing Then
MsgBox """" & strSearch & """ could not be found..."
Exit Function
End If
Set testFindActivate = actCell
End Function
My current sheet is having data in which few cells having Green color, i need to move or copy those rows in which cell having green colour (only few cells coloured with green)to another sheet. i have written code for that but the loop runs on first column for each row wise but wont checks for every cell in that row. i need to check for every row each cell if any cell in green colour then it should copy and paste the entire row in another sheet on next row
Sub Copy()
lastRow = Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
sheet2Counter = 1
For i = 1 To lastRow
ConditionalColor = Worksheets("Sheet1").Cells(i, 1).Interior.ColorIndex
Worksheets("Sheet1").Activate
Worksheets("Sheet1").Range("A" & i & " ").Select
If ConditionalColor = 35 Then
ActiveCell.EntireRow.copy
Worksheets("Sheet2").Activate
lastrow1 = Worksheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Row
If Not Worksheets("Sheet2").Range("A" & lastrow1 & " ") = "" And Not i = 1 Then
lastrow1 = lastrow1 + 1
Worksheets("Sheet2").Range("A" & lastrow1 & " ").Select
With Selection
.PasteSpecial Paste:=xlPasteAll
End With
Else
Worksheets("Sheet2").Range("A1").Select
With Selection
.PasteSpecial Paste:=xlPasteAll
End With
End If
Worksheets("Sheet1").Cells(i, 1).Value
End If
Next
End Sub
You can do something like this:
Option Explicit
Sub CopyByColor()
Dim shtSrc As Worksheet, shtDest As Worksheet
Dim lastRowSrc As Long, nextRowDest As Long, i As Long
Set shtSrc = Worksheets("Sheet1")
Set shtDest = Worksheets("Sheet2")
lastRowSrc = shtSrc.Cells(Rows.Count, 1).End(xlUp).Row
nextRowDest = shtDest.Cells(Rows.Count, 1).End(xlUp).Row + 1
For i = 1 To lastRowSrc
'only check used cells in the row...
If IsColorMatch(Application.Intersect(shtSrc.Rows(i), shtSrc.UsedRange)) Then
shtSrc.Rows(i).Copy shtDest.Cells(nextRowDest, 1)
nextRowDest = nextRowDest + 1
End If
Next i
End Sub
Function IsColorMatch(rng As Range)
Const INDEX_COLOR As Long = 35
Const INDEX_COLOR_BAD As Long = 3 'or whatever...
Dim c As Range, indx
IsColorMatch = False '<< default
For Each c In rng.Cells
indx = c.Interior.ColorIndex
If indx = INDEX_COLOR Then
IsColorMatch = True
Elseif indx = INDEX_COLOR_BAD Then
IsColorMatch = False
Exit Function '<< got a "bad" color match, so exit
End If
Next c
End Function
EDIT: a different implementation of IsColorMatch using the "find formatting" approach:
Function IsColorMatch(rng As Range) As Boolean
If RangeHasColorIndex(Selection.EntireRow, 6) Then
IsColorMatch = Not RangeHasColorIndex(Selection.EntireRow, 3)
Else
IsColorMatch = False
End If
End Function
Function RangeHasColorIndex(rng As Range, indx As Long)
With Application.FindFormat
.Clear
.Interior.ColorIndex = indx
End With
RangeHasColorIndex = Not rng.Find("", , , , , , , , True) Is Nothing
End Function
I have a Sheet with columns A through F. I'm looking for the program to run through all the rows (Is there a way for it to only do active rows?) and check if D1 & E1 & F1 are blank, then hide the row (and so on).
Here's what I have which doesn't really work too well....
Sub Celltest2()
Dim rw As Range, cel As Range
Dim i As Integer
Dim celset As Range
For Each rw In Sheets("Phonelist").Range("D2:F5000").Rows
For Each cel In rw.Cells
If Len(cel.Text) = 0 Then
cel.EntireRow.Hidden = True
End If
Next
Next
End Sub
Try the code below:
Sub Celltest2()
Dim rw As Range, cel As Range
Dim i As Integer
Dim celset As Range
Dim LastRow As Long
With Sheets("Phonelist")
' find last row with data in Columns "D, "E" and "F" >> modify to your needs
LastRow = WorksheetFunction.Max(.Cells(.Rows.Count, "D").End(xlUp).Row, _
.Cells(.Rows.Count, "E").End(xlUp).Row, _
.Cells(.Rows.Count, "F").End(xlUp).Row)
For Each rw In .Range("D2:F" & LastRow).Rows
If WorksheetFunction.CountA(Range("D" & rw.Row & ":F" & rw.Row)) = 0 Then
rw.EntireRow.Hidden = True
End If
Next rw
End With
End Sub
Option 2: You can replace the loop above (the one that starts with For Each rw In .Range("D2:F" & LastRow).Rows) with the following loop:
For i = 2 To LastRow
If WorksheetFunction.CountA(Range("D" & i & ":P" & i)) = 0 Then
Rows(i).EntireRow.Hidden = True
End If
Next i