So I am having a worksheet with 16 columns. And I would like to find out the cells with font color is vbRed. Lets say Range("A5") is the found cell then I would like to copy and paste the entire row into the next row in the current worksheet.
As I am writing Macro, I found my program will keep looping on the row that I copied and pasted. And also I am not sure whether I can use loop, copy and paste together with find method. I will strong appreciate if anyone can help with this.
With my current code:
Sub CopyRow()
Dim Row As Long
Row = ActiveSheet.Range("A1", ActiveSheet.Range("A1").End(xlDown)).Rows.Count
Sheets("Sheet1").Activate
Dim rng As Range
Set rng = Range("A1:A" & Row)
For Each cel In rng
If cel.Font.Color = vbRed Then
cel.Rows.EntireRow.Insert Shift:=xlDown
cel.EntireRow.Copy cel.Offset(-1).EntireRow
cel.Offset(1, 0).Select
End If
Next cel
End Sub
There's infinite loop....
To select the first cell empty in a column :
Range("YOUR COLUMN" & Rows.Count).End(xlUp).Offset(1).Select
If your column A is always filled, you can base your macro on it and then paste the entire row you copied.
Dim SrchRngA as range
Set SrchRngA = Range("a16:a500")
For Each cel In SrchRngA
If InStr(1, cel.Value, "AB") > 0 Then 'search for "AB"
cel.offset(1,0).value = cel.value 'replace next row with current cell value
end if
next cel
Related
I am currently trying to write a macro with which I can check if in Column A there is any value multiple times. If there is a value twice I want the macro to copy the value of the cell next to the cell that is double and paste it, in the cell next to the original cell, divided by the contents of the cell it is pasted in with a ";". I know that sentence is quite complex but I find it hard to describe my problem.
This is the worksheet not "damaged" by my macro
The stuff I just described works more or less, the problem I have is that, if there is a cell with the same content multiple times, and the cell next to those also has the same value, the macro, logically, puts in the value multiple times as well. I don't really know how to stop that. Also, with my macro so far if a cell next to the cell that exists twice is empty, the macro can result to putting many, unwanted, ";".
This is after my macro "destroyed" the sheet
I am still quite new to VBA and very greatful for any help that I can get!
Edit:
Here is what I came up with so far
Option Explicit
Sub Dopplungen()
Dim rng As Range, rng2 As Range, rcell As Range, rcell2 As Range, valueold As String, valuenew As String
Set rng = ThisWorkbook.Sheets("Data").Range("A2:A500")
For Each rcell In rng.Cells
If rcell.Value <> vbNullString Then
For Each rcell2 In rng.Cells
If rcell.Value = rcell2.Value Then
If rcell.Address <> rcell2.Address Then
valueold = rcell.Offset(0, 1).Value
valuenew = rcell2.Offset(0, 1).Value
If rcell.Offset(0, 1).Value <> rcell2.Offset(0, 1).Value Then
If rcell2.Offset(0, 1).Value <> "" Then
If rcell.Offset(0, 1).Value <> "" Then
rcell.Offset(0, 1).Value = valueold & ";" & valuenew
Else
rcell.Offset(0, 1).Value = valuenew
End If
End If
End If
End If
End If
Next rcell2
End If
Next rcell
End Sub
one possibility is using Dictionary object, which has the property of having unique keys
like per this code (explanations in comments):
Option Explicit
Sub main()
Dim fruitRng As Range
Dim cell As Range
With Worksheets("fruits") 'change "fruits" to your actual worksheet name
Set fruitRng = .Range("B1", .Cells(.Rows.Count, 1).End(xlUp)) 'get its range in columns "A:B" from row 1 down to column A last not empty cell
End With
With CreateObject("Scripting.Dictionary")
For Each cell In fruitRng.Columns(1).Cells 'first loop to get unique fruit names and associate them a dictionary
Set .Item(cell.Value) = CreateObject("Scripting.Dictionary")
Next
For Each cell In fruitRng.Columns(1).Cells 'second loop to fill each fruit dictionary with its color
If cell.Offset(, 1).Value <> "" Then 'mind only not empty color cells
With .Item(cell.Value) 'reference the current fruit dictionary
.Item(cell.Offset(, 1).Value) = .Item(cell.Offset(, 1).Value) 'add current color in its keys, so you get a unique list of them
End With
End If
Next
For Each cell In fruitRng.Columns(1).Cells 'third loop to finally write down the colors next to each fruit
cell.Offset(, 1).Value = Join(.Item(cell.Value).Keys, ";")
Next
End With
End Sub
I just want to know how to loop through the non blank cells on Column A. What I'm trying to do is copy the contents on [A1:B1] to be added on top of each non blank cells on Column A. So far I have counted the non blank cells on column A but I'm stuck. I know that an Offset function should be used for this.
Here's my code so far:
Dim NonBlank as Long
NonBlank = WorksheetFunction.CountA(Worksheet(1).[A:A])
For i = 1 to NonBlank
[A1:B1].Copy Offset(1,0). "I'm stuck here"
Next i
If you are trying to fill the headers for each Product, try this...
Sub FillHeaders()
Dim lr As Long
Dim Rng As Range
lr = ActiveSheet.UsedRange.Rows.Count
Application.ScreenUpdating = False
On Error Resume Next
Range("A1:B1").Copy
For Each Rng In Range("A3:A" & lr).SpecialCells(xlCellTypeConstants, 2).Areas
If Rng.Cells(1).Value <> Range("A1").Value Then
Rng.Cells(1).Offset(-1, 0).PasteSpecial xlPasteAll
End If
Next Rng
Application.CutCopyMode = 0
Application.ScreenUpdating = True
End Sub
As example to simulate the effect of Ctrl-Down from Cell A1 and display the Address, Value in the Immediate Window:
Sub HopToNextNonBlankCellBelow()
Dim oRng As Range
Set oRng = Range("A1")
Debug.Print "Cell Address", "Cell Value"
Do
Set oRng = oRng.End(xlDown)
If Not IsEmpty(oRng) Then Debug.Print oRng.Address(0, 0), oRng.Value
Loop Until oRng.Row = Rows.Count
Set oRng = Nothing
End Sub
Try this... I've (probably) overcounted the rows at 1000, but it likely won't make a difference with your performance. If you wanted to be more precise, there are hundreds of articles on how to find the last row of a range. As for the Offset function, it references a cell in relation to the one we're looping through. In the example below, the code is saying cell.offset(0,1) which means one cell to the right of the cell we are currently looping through. A clearer (less loopy!) example would be if you typed: Range("A10").offset(0,1) it would be the same as typing Range("B10")
Dim Cell As Range
For Each Cell In Range("A2:A1000").Cells
If Not IsEmpty(Cell) Then
Cell.Offset(0, 1).Value = Cell.Value
End If
Next Cell
I have section title cells set at 10 pt font while all other data is set at 9 point font in column A. I am trying to write a vba macro to loop through column A to move each title cell down one row(because the csv leaves a blank cell below them) then move on to the next title cell in the column. Here is my attempt but I'm not sure what I'm doing wrong here.
Sub FontSpacing()
Dim Fnt As Range
For Each Fnt In Range("A8:A5000")
If Fnt.Font.Size = "10" Then
ActiveCell.Cut Destination:=ActiveCell.Offset(",1")
End If
Next
Try this
Sub FontSpacing()
Dim r As Range
For Each r In ThisWorkbook.Worksheets("Sheet1").Range("A8:A5000")
If r.Font.Size = 10 Then
r.Offset(1,0).Value = r.Value
r.Value = vbNullString
End If
Next r
End Sub
The issues:
Offset(",1") shouldn't have the speech marks. I.e. it should be Offset(0,1). In fact, if you want to paste to the row below, then it should be Offset(1,0).
Avoid using ActiveCell. It's not the cell that is looping through your range, it's just the cell that was active on the worksheet when you ran the sub.
Fnt is a bad name for a range, it's probably the reason you got confused. When declaring (dimensioning) a range, try to give it a name that makes it clear you're working with a range.
Extra:
Fully qualify your range reference to avoid an implicit reference to the ActiveSheet e.g. ThisWorkbook.Worksheets("Sheet1").Range("A1").
Avoid cutting an pasting by setting the Value directly
Your indentation is out, which makes it look like a complete Sub, but it's missing the End Sub.
Not sure if you meant 1 Row below or 1 Column right so:
To shift 1 Column:
Sub FontSpacing()
Dim rng As Range, cell As Range
Set rng = Range("A1:A5000")
For Each cell In rng
If cell.Font.Size = "10" Then
cell.Offset(0, 1).Value = cell.Value
cell.Clear
End If
Next
End Sub
To shift 1 Row:
Sub FontSpacing()
Dim rng As Range, cell As Range
Set rng = Range("A1:A5000")
For Each cell In rng
If cell.Font.Size = "10" Then
a = cell.Row + 1
Rows(a & ":" & a).Insert Shift:=xlDown, CopyOrigin:=1
cell.Offset(1, 0).Value = cell.Value
cell.Offset(1, 0).Font.Size = "11"
cell.Clear
End If
Next
End Sub
I am building a macro which finds a header and then offsetting it by 1 row below i want to fill a value to the entire column. But when i Run the macro is changing the value of the offset to the Required but once it got to Selection.filldown its copying the header in the place of offset value. And also i am unable to figure out how to skip if the selection is not found. Can anyone help out with this?
Sub Macro7()
Rows("3:3").Select
Selection.Find(What:="item_width").Select
Selection.Offset(1, 0).Select
ActiveCell.FormulaR1C1 = "1"
Selection.FillDown
End Sub
As Christmas007 said, remove the .select and .activate:
Sub Macro7()
Dim rng As Range
Dim rws As Long
rws = Range("A" & Rows.Count).End(xlUp).Row - 2
Set rng = Rows("3:3").Find(What:="item_width")
If Not rng Is Nothing Then
rng.Offset(1, 0).FormulaR1C1 = "1"
rng.Offset(1, 0).Resize(rws).FillDown
End If
End Sub
Also the way you had the fill since it is only one cell it fills it with the cells directly above. To fill a range you need to dictated the range extents. The above is one way.
I've seen several questions asking about moving cells from one workbook to another or one sheet to another using VBA, but I'm hoping to move information from one column to another in the same sheet based on specific criteria.
I wrote this code to move cells from column A if they contained the word "save" to column I in the same sheet:
Sub Findandcut()
Dim rngA As Range
Dim cell As Range
Set rngA = Sheets("Jan BY").Range("A2:A1000")
For Each cell In rngA
If cell.Value = "save" Then
cell.EntireRow.Cut
Sheets("Jan BY").Range("I2").End(xlDown).Select
ActiveSheet.Paste
End If
Next cell
End Sub
But, while this macro doesn't display any errors when I run it, it also doesn't seem to do much of anything else, either. Nothing is selected, cut, or pasted. Where in the code did I go wrong?
move cells from column A if they contained the word "save" to column I
in the same sheet
Your code doesn't do anything like this.
To accomplish what your requirements are, you would need something like this:
Sub Findandcut()
Dim row As Long
For row = 2 To 1000
' Check if "save" appears in the value anywhere.
If Range("A" & row).Value Like "*save*" Then
' Copy the value and then blank the source.
Range("I" & row).Value = Range("A" & row).Value
Range("A" & row).Value = ""
End If
Next
End Sub
Edit
If you want to shift the entire contents of row over so it starts at column I, just replace the relevant section of code:
If Range("A" & row).Value Like "*save*" Then
' Shift the row so it starts at column I.
Dim i As Integer
For i = 1 To 8
Range("A" & row).Insert Shift:=xlToRight
Next
End If
Perhaps something like:
Sub Findandcut()
Dim rngA As Range
Dim cell As Range
Set rngA = Sheets("Jan BY").Range("A2:A1000")
For Each cell In rngA
If cell.Value = "save" Then
cell.Copy cell.Offset(0, 8)
cell.Clear
End If
Next cell
End Sub
This code scans down the column, detects the matches and performs the copy. Copying brings over the format as well as the value.
Sub Findandcut()
Dim rngA As Range
Dim cell As Range
Set rngA = Sheets("Jan BY").Range("A2:A1000")
For Each cell In rngA
If cell.Value = "save" Then
Sheets("Jan BY").Range("I" & Rows.Count).End(xlUp).Select
Selection.Value = cell.Value
cell.Delete Shift:=xlUp
End If
Next cell
End Sub