Looking for VBA to copy cell above (in column E) if cell in E is empty and AJ is anything other than empty. Currently this is copying the cell above but is not taking into account the AJ column. Fairly new to VBA and not sure where I am going wrong. Any input is greatly appreciated.
Sub CopyFIN() 'copies FIN from account above if E is empty and AJ is anything other than empty
Dim lr As Long
Dim rcell As Range
Dim col As Range
Application.ScreenUpdating = False
lr = Cells(Rows.Count, 6).End(xlUp).Row
Set col = Range("E12:E" & lr)
Set col2 = Range("AJ12:AJ" & lr)
For Each rcell In col2
If rcell.Value <> "" Then
End If
Next
For Each rcell In col
If rcell.Value = "" Then
rcell.Offset(-1, 0).Copy rcell
End If
Next
Application.ScreenUpdating = True
End Sub
Try this. Your first loop wasn't doing anything and your second was only checking column E.
Sub CopyFIN() 'copies FIN from account above if E is empty and AJ is anything other than empty
Dim lr As Long
Dim rcell As Range
Dim col As Range
Application.ScreenUpdating = False
lr = Cells(Rows.Count, 6).End(xlUp).Row
Set col = Range("E12:E" & lr)
For Each rcell In col
If Len(rcell) = 0 And Len(Cells(rcell.Row, "AJ")) > 0 Then
rcell.Offset(-1, 0).Copy rcell
End If
Next
Application.ScreenUpdating = True
End Sub
Related
I am relatively new to VBA and have this script which searches for the Array "VC" and changes the matching cells within the range by colouring them red.
My problem is I need to change the criteria from -MyArr = Array("VC") to instead search column A and find any corresponding matches in the same row within the range "B2:D20" then colour the matches red as the below script does.
As per the below script I don't want a case sensitive search and am using XLpart to include partial matches. Please help, thanks
Sub Mark_cells_in_column()
Dim FirstAddress As String
Dim MyArr As Variant
Dim Rng As Range
Dim I As Long
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
MyArr = Array("VC")
With Sheets("Sheet1").Range("A2:d20")
For I = LBound(MyArr) To UBound(MyArr)
Set Rng = .Find(What:=MyArr(I), _
After:=.Cells(.Cells.Count), _
LookIn:=xlFormulas, _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
If Not Rng Is Nothing Then
FirstAddress = Rng.Address
Do
Rng.Interior.ColorIndex = 3
Set Rng = .FindNext(Rng)
Loop While Not Rng Is Nothing And Rng.Address <> FirstAddress
End If
Next I
End With
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
Sample data:
You may try this
Public Sub Main()
Dim cell As Range, cell2 As Range
For Each cell In ThisWorkbook.Worksheets("Sheet1").Range("A2:A20")
For Each cell2 In cell.Offset(, 1).Resize(, 3)
If Instr(cell.Value, cell2.Value) > 0 Then cell2.Interior.ColorIndex = 3
Next
Next
End Sub
Or
Public Sub Main()
Dim cell As Range
With ThisWorkbook.Worksheets("Sheet1")
For Each cell In .Range("B:D").SpecialCells(xlCellTypeConstants)
If Instr(.Cells(cell.Row,1).Value, cell.Value) > 0 Then cell.Interior.ColorIndex = 3
Next
End With
End Sub
This will go through all cells in column A, split each cell value (comma-delimited) into separate items, and search for each item in the same row (case insensitive), through columns B to D
Option Explicit
Public Sub MarkCellsInColumns()
Dim arr As Variant, r As Long, c As Long, i As Long, f As Range, vals As Variant
arr = Sheet1.UsedRange
With Sheet1.UsedRange
For r = 1 To UBound(arr)
If Not IsError(arr(r, 1)) Then
If Len(arr(r, 1)) > 0 Then
vals = Split(arr(r, 1), ",") 'check each value in one cell
For i = 0 To UBound(vals)
For c = 2 To UBound(arr, 2) 'check all columns on same row
If LCase(Trim$(vals(i))) = LCase(Trim$(arr(r, c))) Then
If f Is Nothing Then
Set f = .Cells(r, c)
Else
Set f = Union(f, .Cells(r, c)) 'union of found cells
End If
f.Select
End If
Next c
Next i
End If
End If
Next r
If Not f Is Nothing Then f.Interior.Color = vbRed 'color all in one operation
End With
End Sub
Result
I am working on the below code to insert same entire row below/beneath original one. I had a hard time fulfilling the requirement because I am just new to making macros.
I already tried searching but not able to code correctly. It is working to insert an empty row. But what I need is to insert the row that met the condition. Below is the screenshot/code for my macro.
Private Sub CommandButton1_Click()
Dim rFound As Range, c As Range
Dim myVals
Dim i As Long
myVals = Array("LB") '<- starts with 51, VE etc
Application.ScreenUpdating = False
With Range("F1", Range("F" & Rows.Count).End(xlUp))
For i = 0 To UBound(myVals)
.AutoFilter field:=1, Criteria1:=myVals(i)
On Error Resume Next
Set rFound = .Offset(2).Resize(.Rows.Count - 1) _
.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
.AutoFilter
If Not rFound Is Nothing Then
For Each c In rFound
Rows(c.Row + 1).Insert
c.Offset(1, -1).Value = ActiveCell.Value
Next c
End If
Next i
End With
Application.ScreenUpdating = True
End Sub
Sub Test()
Dim rng As Range
Dim rngData As Range
Dim rngArea As Range
Dim rngFiltered As Range
Dim cell As Range
Set rng = Range("A1").CurrentRegion
'Exclude header
With rng
Set rngData = .Offset(1).Resize(.Rows.Count - 1)
End With
rng.AutoFilter Field:=6, Criteria1:="LB"
Set rngFiltered = rngData.Columns("F:F").SpecialCells(xlCellTypeVisible)
rng.AutoFilter Field:=6
For Each rngArea In rngFiltered.Areas
For Each cell In rngArea
'// When inserting a row,
'// iteration variable "cell" is adjusted accordingly.
Rows(cell.Row + 1).Insert
Rows(cell.Row).Copy Rows(cell.Row + 1)
Next
Next
End Sub
Below is the code I just used . Thank you!
Private Sub CommandButton2_Click()
Dim x As Long
For x = ActiveSheet.UsedRange.Rows.CountLarge To 1 Step -1
If Cells(x, "F") = "LB" Then
Cells(x, "F") = "ComP"
Cells(x + 1, "F").EntireRow.Insert
Cells(x, "F").EntireRow.Copy Cells(x + 1, "F").EntireRow
End if
Next x
End Sub
I am trying to join cells in a row if a value exists in a cell in that row.
The data has been imported from a .txt file and various sub headers are split along 2, 3 or 4 columns.
The cells cant be merged as the data will only be kept from the first cell.
The only words which are always constant are "contain" and "for" in column B.
What I've tried resembles this:
If cell.Value like "contain", or "for" then join all cells from column "A" to column "H" into column "B", align them centrally and make them bold.
thanks, in advance, for any help.
Edit Here is the code:
Sub Joining()
Dim N As Long, i As Long, r1 As Range, r2 As Range
Dim z As Long
Dim arr() As Variant
z = 1
With Activesheet
N = .Cells(Rows.Count, "A").End(xlUp).Row
For i = 1 To N
If .Cells(i, "B").Value Like "Summary*" Then
arr = .Range(.Cells(i, "A"), .Cells(i, "H")).Value
.Cells(z, "B").Value = Join(arr, " ")
z = z + 1
End If
Next i
End With
End Sub
Not sure if this is exactly what you want but it will get you close:
Sub summary()
Dim sh1 As Worksheet, sh2 As Worksheet
Dim N As Long, i As Long, r1 As Range, r2 As Range
Dim z As Long
Dim arr() As Variant
z = 1
Set sh1 = ActiveSheet
With ActiveWorkbook
Set sh2 = .Worksheets.Add(After:=.Sheets(.Sheets.Count))
End With
With sh1
N = .Cells(Rows.Count, "A").End(xlUp).Row
For i = 1 To N
If .Cells(i, "A").Value Like "Summary*" Then
arr = .Range(.Cells(i, "A"), .Cells(i, "H")).Value
sh2.Cells(z, "A").Value = Join(arr, " ")
z = z + 1
End If
Next i
End With
End Sub
Ok, so I've created an answer, but it ain't pretty (kinda like the whole project I've created).
It works although I'm sure there is a much simpler way of creating it.
Maybe someone can have a go at cleaning it up?
Sub SelRows()
Dim ocell As Range
Dim rng As Range
Dim r2 As Range
For Each ocell In Range("B1:B1000")
If ocell.Value Like "*contain*" Then
Set r2 = Intersect(ocell.EntireRow, Columns("A:G"))
If rng Is Nothing Then
Set rng = Intersect(ocell.EntireRow, Columns("A:G"))
Else
Set rng = Union(rng, r2)
End If
End If
Next
Call JoinAndMerge
If Not rng Is Nothing Then rng.Select
Set rng = Nothing
Set ocell = Nothing
End Sub
Private Sub JoinAndMerge()
Dim outputText As String, Rw As Range, cell As Range
delim = " "
Application.ScreenUpdating = False
For Each Rw In Selection.Rows
For Each cell In Rw.Cells
outputText = outputText & cell.Value & delim
Next cell
With Rw
.Clear
.Cells(1).Value = outputText
.Merge
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = True
End With
outputText = ""
Next Rw
Application.ScreenUpdating = True
End Sub
The below code works fine to find the first empty cell in a given column (here column B). But what I need is a code to find the first blank cell in that column.
Sub macro1()
Dim sourceCol As Integer, rowCount As Integer, currentRow As Integer
Dim currentRowValue As String
sourceCol = 2 'column B has a value of 2
rowCount = Cells(Rows.Count, sourceCol).End(xlUp).Row
'for every row, find the first blank cell and select it
For currentRow = 1 To rowCount
currentRowValue = Cells(currentRow, sourceCol).Value
If IsEmpty(currentRowValue) Or currentRowValue = "" Then
Cells(currentRow, sourceCol).Select
End If
Next
End Sub
Also, it should start looking from row 10 instead of row 1.
Can somebody rewrite this code to do this?
Could something like this be what you're looking for:
Sub test()
Dim ws As Worksheet
Set ws = ActiveSheet
For Each cell In ws.Columns(2).Cells
If IsEmpty(cell) = True Then cell.Select: Exit For
Next cell
End Sub
This will run through each cell in column B in the active worksheet and select the first empty one it comes across. To set the sheet to a particular one Change Set ws = ActiveSheet to Set ws = Sheets("EnterSheetNameHere")
Or you could try using:
Sub test()
Dim ws As Worksheet
Set ws = ActiveSheet
For Each cell In ws.Columns(2).Cells
If Len(cell) = 0 Then cell.Select: Exit For
Next cell
End Sub
My problem is solved by using the following code.
Sheets("sheet1").Select
Dim LR2 As Long, cell2 As Range, rng2 As Range
With Sheets("sheet1")
LR2 = .Range("B" & Rows.Count).End(xlUp).Row
For Each cell2 In .Range("B8:B" & LR2)
If cell2.Value <> "" Then
If rng2 Is Nothing Then
Set rng2 = cell2
Else
Set rng2 = Union(rng2, cell2)
End If
End If
Next cell2
rng2.Select
End With
Just my two cents.
The function will look for the first encountered BLANK cell in a range, so it should work with columns and rows.
'Find first BLANK cell in a given range, returnt a range (one cell)
Function FirstBlank(ByVal rWhere As Range) As Range
Dim vCell As Variant
Dim answer As Range
Set answer = Nothing
For Each vCell In rWhere.Cells
If Len(vCell.Formula) = 0 Then
Set answer = vCell
Exit For
End If
Next vCell
Set FirstBlank = answer
End Function
And then do whatever you want with the cell.
Try this code to select the first empty cell below cell B10. But it requires B10 and B11 to be pre-occupied.
Range("B10").End(xlDown).Offset(1, 0).Select
or
Range("B100000").End(xlUp).Offset(1, 0).Select
This is what I have already, and it works great in removing #N/As from the range. I am now looking to modify it to do the same thing for cells that contain 0.
Sub DeleteErrorRows()
Dim r As Range
Set r = Range("B:B").SpecialCells(xlCellTypeConstants, 16).EntireRow
r.Copy Sheets("Sheet2").Range("A1")
r.Delete
End Sub
Thanks :)
Try this. It autofilters your column and keeps rows that have the findMe value in your source worksheet. You can set it to 0 as I have in the example or to whatever else you want. It copies those rows (except for the header row) to the target sheet and then deletes them from the source sheet.
Note that this also finds the first empty row on the target sheet so that you can run it multiple times without overwriting what you've already moved to the target sheet.
Sub CopyThenDeleteRowsWithMatch()
Dim wb As Workbook
Dim ws As Worksheet
Dim tgt As Worksheet
Dim rng As Range
Dim lastRow As Long
Dim firstPasteRow As Long
Dim findMe As String
Set wb = ThisWorkbook
Set ws = wb.Sheets("Sheet1")
Set tgt = wb.Sheets("Sheet2")
lastRow = ws.Range("B" & ws.Rows.Count).End(xlUp).Row
firstPasteRow = tgt.Range("B" & tgt.Rows.Count).End(xlUp).Row + 1
findMe = "0"
Set rng = ws.Range("B1:B" & lastRow)
' filter and delete all but header row
With rng
.AutoFilter Field:=1, Criteria1:="=" & findMe
With .Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow
.Copy tgt.Range("A" & firstPasteRow)
.Delete
End With
End With
' turn off the filters
ActiveSheet.AutoFilterMode = False
End Sub
Consider:
Sub DeleteZeroRows()
Dim r As Range, rTemp As Range, rB As Range
Set rB = Intersect(Range("B:B"), ActiveSheet.UsedRange)
Set r = Nothing
For Each rTemp In rB
If Not IsEmpty(rTemp) And rTemp.Value = 0 Then
If r Is Nothing Then
Set r = rTemp
Else
Set r = Union(r, rTemp)
End If
End If
Next rTemp
Set r = r.EntireRow
r.Copy Sheets("Sheet2").Range("A1")
r.Delete
End Sub