I have a vba code that copies a file multiple times and renames the output after a list of names in column D from sheet "Linkuire".
Column D is full of concatenate formulas that bring data into cells till D1000.
When the concatenate formulas return "" (as in nothing) i want the code to ignore that cell.
' the range of cells that contain the rename list
With ActiveWorkbook.Sheets("Linkuire")
Set rRenameList = .Range("D2", .Cells(.Rows.Count, "D").End(xlUp))
End With
Now it just takes into account all D2 to D1000 cells even if some are = ""
How can I make the code ignore all cells where the return of the concatenate is "" ? (I have the same problem with a vba code that converts a certain sheet into pdf - with data got from concatenate formulas. It converts all cells even if concatenate return "" and is blank)
Thank you..
edited since pure SpecialCells() approach wouldn't work
You could use following two approaches and avoid looping:
AutoFilter() and SpecialCells() approach:
With ActiveWorkbook.Sheets("Linkuire")
With .Range("D1", .Cells(.Rows.count, "D").End(xlUp))
.AutoFilter Field:=1, Criteria1:="<>" '<--| filter out blanks
If Application.WorksheetFunction.Subtotal(103, .Cells) > 1 Then Set rRenameList = .Resize(.Rows.count - 1).Offset(1).SpecialCells(xlCellTypeVisible)
End With
.AutoFilterMode = False
End With
Formula and SpecialCells() approach
With ActiveWorkbook.Sheets("Linkuire")
With .Range("D2", .Cells(.Rows.count, "D").End(xlUp))
.Offset(, 1).FormulaR1C1 = "=IF(RC[-1]="""", 1,"""")"
Set rRenameList = .Offset(, 1).SpecialCells(xlCellTypeFormulas, xlNumbers).Offset(, -1)
.Offset(, 1).ClearContents
End With
End With
in this approach you're writing a formula in a "helper" column I chose to be the adjacent to the right. It can be adjusted to any other offset
This should work. It will loop through your range, and only add the cell address to your rRenameList when the length is greater than or equal to 1.
Sub Test()
' Adapted from http://stackoverflow.com/a/8320884/4650297
Dim rng1 As Range, rRenameList As Range, cel As Range
With ActiveWorkbook.Sheets("Linkuire")
Set rng1 = .Range("D2", .Cells(.Rows.Count, "D").End(xlUp))
End With
For Each cel In rng1
If Len(cel) >= 1 Then
If Not rRenameList Is Nothing Then
Set rRenameList = Union(rRenameList, cel)
Else
' the first valid cell becomes rng2
Set rRenameList = cel
End If
End If
Next cel
Debug.Print rRenameList.Address
End Sub
Related
The situation:
In cells "D18:D94" and "E18:94" I have dropdown lists (data validation). In an additional sheet "Sheet2" in cells "R18:94", I have a formula.
Output wanted:
If cell "E18" is not empty then insert the value from "Sheet2!U18" to cell "F18". I want to loop this for each row from range.
I made something like this, but I don't know how to loop.
If Sheets("Sheet1").Range("E18").Value <> "" Then
Sheets("Sheet1").Range("F18").Value = Sheets("Sheet2").Range("R18")
End if
I don't want to set formula in Sheet1! "F" column because I have a dynamic print area.
Try below sub-
Sub FillData()
Dim sRng As Range, Rng As Range
Set sRng = Sheets("Sheet1").Range("E18:E94")
For Each Rng In sRng
If Rng.Value <> "" Then
Rng.Offset(0, 1).Value = Sheets("Sheet2").Range("R" & Rng.Row)
End If
Next Rng
Set sRng = Nothing
End Sub
Hi I am trying to cut the even rows and then paste it beside the odd rows.
My data looks like this
I have the following code which will only cut Row 2 and paste it beside Row 1
Range("B2:E2").Cut Range("F2")
But I can't possible to it for every single row. So how do I make a loop such that it will do the rest of the work for me?
The ideal result should look something like this
This works for me:
Sub SubCutAndPaste()
'Declaring variable.
Dim RngRange01 As Range
'Setting variable.
Set RngRange01 = ActiveSheet.Range("A1:E1")
'Starting a Do-Loop cycle that will end when all the cells in the given RngRange01 are _
blank.
Do Until Excel.WorksheetFunction.CountBlank(RngRange01) = RngRange01.Cells.Count
'Cutting-pasting the second lane. The second lane has the same columns as the _
RngRange01 and it is offset by 1 column.
RngRange01.Offset(1, 1).Cut RngRange01.Offset(0, RngRange01.Columns.Count)
'Setting RngRange01 for the next lane.
Set RngRange01 = RngRange01.Offset(2, 0)
Loop
End Sub
Try the below:
Change the offset amounts and range in for loop depending on the data.
Sub ReFormat()
Dim cell
Dim CopyRange As String
Dim PasteRange As String
For Each cell In Range("A1:A12")
' Filter out only odd rows
If (cell.Row Mod 2) <> 0 Then
'create range string for values to copy
CopyRange = (cell.Offset(1, 1).Address + ":" + cell.Offset(1, 5).Address)
'create range string for values to paste into
PasteRange = (cell.Offset(0, 5).Address + ":" + cell.Offset(0, 9).Address)
Range(CopyRange).Copy
Range(PasteRange).PasteSpecial xlPasteValues
Range(CopyRange).ClearContents
End If
Next
End Sub
I have written a few lines of code that work like I want them too but I don't know how to repeat it through all rows of my data.
This probably seems like a rather simple thing but since I started VBA just a few days ago I struggle with this line of code
If I continue with ActiveCell.Offset(-1,-4) after my code it's a bug and I don't know how to repeat the code through all rows.
Sub SelectRowsWithNoBlanks()
Range("A2").Select
If ActiveCell.Offset(0, 0).Value <> "" And ActiveCell.Offset(0, 1) <> "" And ActiveCell(0, 1) <> "" And ActiveCell(0, 1) <> "" Then
Range(ActiveCell, Cells(ActiveCell.Row, ActiveCell.Column + 4)).Select
End If
End Sub
#SiddharthRout As I don't have Access to the data yet I can't tell. But I thought extending the code for more columns later on wouldn't be a problem. So in the code I have written now I was checking for the columns A-D but I thought I could easily add the "checking" for more columns if needed – Anna von Blohn 43 secs ago
In that case, here is a sample code.
Logic
As #Pᴇʜ mentioned avoid the use of .Select. Work with the objects.
Find the last row and loop through the rows. To find the last you you may want to see This
One way (which I am using) is to count the number of cells which are filled using Application.WorksheetFunction.CountA. So if it is columns A to D then there should be 4 cells to be filled to consider the "row" as filled. Similarly for Cols A to E, there should be 5 cells to be filled to consider the "row" as filled as so on.
Code
I have commented the code. So if you have a problem understanding it, let me know.
Option Explicit
Sub SelectRowsWithNoBlanks()
Dim ws As Worksheet
Dim lRow As Long, i As Long
Dim myRange As Range, rng As Range
'~~> Change this to the relevant sheet
Set ws = Sheet1
With ws
'~~> Find the last row in Col A
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
'~~> Loop through the rows
For i = 2 To lRow
'~~> Change this as applicable
Set rng = .Range("A" & i & ":D" & i)
'~~> Check if the range is completely filled
If Application.WorksheetFunction.CountA(rng) = rng.Columns.Count Then
'~~> Store the range in a range object
If myRange Is Nothing Then
Set myRange = rng
Else
Set myRange = Union(myRange, rng)
End If
End If
Next i
End With
'If Not myRange Is Nothing Then Debug.Print myRange.Address
'~~> Check if any filled rows were found
If Not myRange Is Nothing Then
With myRange
'
'~~> Do what you want with the range
'
End With
Else
MsgBox "No filled rows were found"
End If
End Sub
I am trying to transfer two rows of Sheet1 (randomly and based on certain criteria) into Sheet3.
The values in cells "P2" and "P5" indicate the row number to be transferred, and column "A" has row numbers.
There's no possibility that values in "P2" and "P5" could match multiple rows in column "A". They should match 1 row each, so only one row should be copied per "P2" and "P5". Yet, sometimes I see multiple rows getting copied.
Below is the code:
Sub copyrows()
Dim tfRow As Range, cell As Object
Set tfRow = Range("A1:A") 'Range which includes the values
For Each cell In tfRow
If IsEmpty(cell) Then
Exit Sub
End If
If cell.Value = Range("P2").Value Then
cell.EntireRow.Copy
Sheet3.Select 'Target sheet
ActiveSheet.Range("A65536").End(xlUp).Select
Selection.Offset(1, 0).Select
ActiveSheet.Paste
End If
Next
End Sub
Sub copyrows2()
Dim tfRow2 As Range, cell As Object
Set tfRow2 = Range("A1:A") 'Range which includes the values
For Each cell In tfRow2
If IsEmpty(cell) Then
Exit Sub
End If
If cell.Value = Range("P5").Value Then
cell.EntireRow.Copy
Sheet3.Select 'Target sheet
ActiveSheet.Range("A65536").End(xlUp).Select
Selection.Offset(1, 0).Select
ActiveSheet.Paste
End If
Next
End Sub
As #urdearboy mentioned in the commnets above, you need to add a row to your second A column range to avoid getting the error.
To merge two conditions, in your case add an Or to your If.
To run the code faster, don't Select and Activate different sheets, it takes a long time for the code to run. Instead, use a Range object, like CopyRng and every time the if criteria is ok, you add that cell to the range using the Union function.
Read HERE about the Union functionality.
More comments inside the code's notes below.
Modified Code
Option Explicit
Sub copyrows()
Dim Sht1 As Worksheet, Sht3 As Worksheet
Dim tfRow As Range, C As Range ' use Range not Object, also try not to use Cell it's close to Cells
Dim CopyRng As Range
Dim LastRow As Long
Set Sht1 = Sheet1
Set Sht3 = Sheet3
With Sht1
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row ' get last row with data in column A
Set tfRow = .Range("A1:A" & LastRow) 'Range which includes the values
For Each C In tfRow
If IsEmpty(C) Then
Exit Sub
End If
If C.Value = .Range("P2").Value Or C.Value = .Range("P5").Value Then ' use Or to combine both scenarios
If Not CopyRng Is Nothing Then
Set CopyRng = Application.Union(CopyRng, C) ' use Union to merge multiple ranges
Else
Set CopyRng = C
End If
End If
Next C
End With
' make sure there is at least one cells in your merged range
If Not CopyRng Is Nothing Then
' get last row with data in "sheet3"
LastRow = Sht3.Cells(Sht3.Rows.Count, "A").End(xlUp).Row
CopyRng.EntireRow.Copy Destination:=Sht3.Range("A" & LastRow + 1)
End If
End Sub
I want to do the following in a non-manual way:
I have a cell with multiple values separated by line breaks which I want to split up BUT keep the values in the other columns the same.
Thank you
As SJR pointed out, the following should work:
Sub Foo()
'working for active sheet
'copy to the end of sheets collection
ActiveSheet.Copy After:=Sheets(Sheets.Count)
Dim tmpArr As Variant
Dim Cell As Range
For Each Cell In Range("B1", Range("B2").End(xlDown))
If InStr(1, Cell, Chr(10)) <> 0 Then
tmpArr = Split(Cell, Chr(10))
Cell.EntireRow.Copy
Cell.Offset(1, 0).Resize(UBound(tmpArr), 1). _
EntireRow.Insert xlShiftDown
Cell.Resize(UBound(tmpArr) + 1, 1) = Application.Transpose(tmpArr)
End If
Next
Application.CutCopyMode = False
End Sub