Fill in the entire column according to the last data in the table - Does not work - excel

I have a formula in Column A2.
I have a table similar to this:
Formula
Note
Datum
I am very happy because I am
Years
years old
=CONCATENATE(TEXT(C2;"dd-mm-yyyy");$D$1;E2;$F$1)
Any word, TEXT
01.04.2021
21
Autofill
Any word, TEXT 2
01.04.2021
25
I want to transfer it and use it automatically for the whole column. However, I tried possible and impossible ways to do it, but none of them worked. I also looked at forums such as here:
I don't have all the data filled in the table, so I want "excel" to look for the last row in which the record is and try to calculate the formula and return it to the last cell in column A.
Thank you in advance for all the help
(The formula joins the text together) =CONCATENATE(TEXT(C2;"dd-mm-yyyy");$D$1;E2;$F$1)
Sub AutofilCol()
' Apply to the entire column Autofill
Range("A1").Offset(1, 0).Activate
ActiveCell.FormulaR1C1 = _
"=CONCATENATE(TEXT(RC[2],""dd-mm-yyyy""),R1C4,RC[4],R1C6)"
' AutoFill
Selection.AutoFill Destination:=Range("A2:A").End(xlDown).Row
ActiveCell.EntireColumn.AutoFit
End Sub

It looks like this is what you want to do:-
Sub AutofillCol()
Dim Rl As Long ' last used row in column C
Dim Rng As Range
Rl = Cells(Rows.Count, "C").End(xlUp).Row
Set Rng = Range(Cells(2, "A"), Cells(Rl, "A"))
Rng.FormulaR1C1 = "=CONCATENATE(TEXT(RC[2],""dd-mm-yyyy""),R1C4,RC[4],R1C6)"
End Sub

Copy Formulas (Defining a Range)
In this case, there is no need to Activate (or Select) anything neither is the use of AutoFill (FillDown).
Let's say the first solution is the most flexible (reliable) but also the most complex. To better understand it, see the ranges at the various stages of the code printed in the Immediate window (CTRL+G). The flexibility is in the option to use any first cell address e.g. C5, D10, etc. and it will still work.
Depending on your data, you might easily get away with the remaining two solutions.
I didn't include any solution using End since you got that covered by another post.
Option Explicit
Sub copyFormulas()
Const First As String = "A1"
Dim ws As Worksheet: Set ws = ActiveSheet
Dim fCell As Range ' Last Cell in First Row Range
Dim frg As Range ' First Row Range of Table Range
With ws.Range(First)
Set fCell = .Resize(, .Worksheet.Columns.Count - .Column + 1) _
.Find("*", , xlFormulas, , , xlPrevious)
If fCell Is Nothing Then Exit Sub
Set frg = .Resize(, fCell.Column - .Column + 1)
Debug.Print "First", fCell.Address, frg.Address
End With
Dim tCell As Range ' Last Cell in Table Range
Dim trg As Range ' Table Range
With frg
Set tCell = .Resize(.Worksheet.Rows.Count - .Row + 1) _
.Find("*", , xlFormulas, , xlByRows, xlPrevious)
Set trg = .Resize(tCell.Row - .Row + 1)
End With
Debug.Print "Table", tCell.Address, trg.Address
Dim drg As Range ' Destination Range
Set drg = trg.Columns(1).Resize(trg.Rows.Count - 1).Offset(1)
Debug.Print "Destination", drg.Address
drg.FormulaR1C1 = "=CONCATENATE(TEXT(RC[2],""dd-mm-yyyy""),R1C4,RC[4],R1C6)"
' Or.
'drg.Formula = "=CONCATENATE(TEXT(C2,""dd-mm-yyyy""),$D$1,E2,$F$1)"
End Sub
Sub copyFormulasUsedRange()
With ActiveSheet.UsedRange.Columns(1)
.Resize(.Rows.Count - 1).Offset(1).FormulaR1C1 _
= "=CONCATENATE(TEXT(RC[2],""dd-mm-yyyy""),R1C4,RC[4],R1C6)"
End With
End Sub
Sub copyFormulasCurrentRegion()
With ActiveSheet.Range("A1").CurrentRegion.Columns(1)
.Resize(.Rows.Count - 1).Offset(1).FormulaR1C1 _
= "=CONCATENATE(TEXT(RC[2],""dd-mm-yyyy""),R1C4,RC[4],R1C6)"
End With
End Sub

Related

VBA why do I have blank rows after appending tables?

VBA newb here.
Essentially, I'm collecting weekly compliance records for week over week data.
My main issue is that I have a queried table that is dynamic and on a good week it's empty.
I would like to be able to pull the contents of this table and paste them to the first empty row below a static table that contains year to date data.
This step is an easy one to accomplish manually, but I'm looking to automate for the sake of handing this report off to my less-than-tech-savvy team members.
This question: How to copy and paste two separate tables to the end of another table in VBA? has given me most of what I'm using so far. I've swapped a few of their values and declarations to be relevant to my sheet and ranges, but for the most part it's copy/paste with the listed solution for "Destination: ="
For the most part, this block does the exact thing I'm after:
(I've commented out GCC's second range, but intend to utilize it once this one's settled.)
Sub Inv_Copy_Paste()
Dim TC As Worksheet
'Dim Chart As Worksheet
Dim lr2 As Long
Set TC = Worksheets("TC Data Dump")
'Set Chart = Worksheets("Inventory for Charts")
lr2 = TC.Cells(Rows.Count, 1).End(xlUp).Row
With TC
.Range("O2", ("W2" & .Range("O" & Rows.Count).End(xlUp).Row)).Copy Destination:=TC.Cells(Rows.Count, 1).End(xlUp).Offset(1)
'.Range("K2", ("S2" & .Range("K" & Rows.Count).End(xlUp).Row)).Copy Destination:=Chart.Range("A" & lr2 + 1)
End With
End Sub
The one exception that I'm running into is that once the code copies populated data over, it adds a handful of blank lines below the data:
20 Blank Rows
Is this something I'm overlooking in the code that's already here?
I'll grant that I barely understand what the code is doing in the With TC portion, so any additional context would be greatly appreciated.
Bonus question: Will I need a separate Sub/Worksheet when I attempt to copy another dynamic query table to a second static table?
Dealing With Blanks
If your data is in Excel tables, you should use their methods and properties.
If you don't wanna, you'll need to write special, often complicated codes.
End(xlUp) will only go up to the last row (cell) in the table. If there are empty or blank rows at the bottom, they will also be copied.
The Find method with xlFormulas will go up to the last non-empty row while with xlValues, it will go up (further) to the last non-blank row.
Initial
Result
Main
Sub InvCopyPaste()
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim wsTC As Worksheet: Set wsTC = wb.Sheets("TC Data Dump")
Dim wsInv As Worksheet: Set wsInv = wb.Sheets("Inventory for Charts")
Dim srg As Range, drg As Range
' Source: 'wsTC' to Destination: 'wsTC'
Set srg = RefNonBlankRange(wsTC.Range("O2:W2"))
If Not srg Is Nothing Then
Set drg = RefFirstNonBlankRowRange(wsTC.Range("A2") _
.Resize(, srg.Columns.Count)).Resize(srg.Rows.Count)
drg.Value = srg.Value ' for only values (most efficient)
'srg.Copy drg ' instead: for values, formulas and formats
Debug.Print "Copied from " & srg.Address & " to " & drg.Address & "."
End If
' Source: 'wsTC' to Destination: 'wsInv'
Set srg = RefNonBlankRange(wsTC.Range("K2:S2"))
If Not srg Is Nothing Then
Set drg = RefFirstNonBlankRowRange(wsInv.Range("A2") _
.Resize(, srg.Columns.Count)).Resize(srg.Rows.Count)
drg.Value = srg.Value ' for only values (most efficient)
'srg.Copy drg ' instead: for values, formulas and formats
Debug.Print "Copied from " & srg.Address & " to " & drg.Address & "."
End If
End Sub
The Help
Function RefNonBlankRange( _
ByVal FirstRowRange As Range) _
As Range
With FirstRowRange
Dim cel As Range: Set cel = .Resize(.Worksheet.Rows.Count - .Row + 1) _
.Find("*", , xlValues, , xlByRows, xlPrevious)
If Not cel Is Nothing _
Then Set RefNonBlankRange = .Resize(cel.Row - .Row + 1)
End With
End Function
Function RefFirstNonBlankRowRange( _
ByVal FirstRowRange As Range) _
As Range
Dim rg As Range: Set rg = FirstRowRange.Rows(1)
With rg
Dim cel As Range: Set cel = .Resize(.Worksheet.Rows.Count - .Row + 1) _
.Find("*", , xlValues, , xlByRows, xlPrevious)
If Not cel Is Nothing Then Set rg = .Offset(cel.Row - .Row + 1)
End With
Set RefFirstNonBlankRowRange = rg
End Function
Debug.Print Results in the Immediate window (Ctrl+G)
Copied from $O$2:$W$6 to $A$4:$I$8.
Copied from $K$2:$S$6 to $A$6:$I$10.
Firstly, the row count is counting the number of lines in the first column.
-lr2 = TC.Cells(Rows.Count, 1).End(xlUp).Row
Here.
Rather than counting the number of rows in the tablese you're trying to copy.
If you change the number 1 in this line to the column you are copying. I think its "O" which would be 15.
Then I'm afraid you'd have to redefine the lr2 for the second table or make another variable for it.
lr3 = TC.Cells(Rows.Count, 11).End(xlUp).Row '11 for the k column
Please let me know if this helps.
Sub oddzac()
Dim RowCount As Integer
ActiveSheet.Range("O2", Cells(Range("W" & Rows.Count).End(xlUp).Row, "W")).Copy Cells(Range("A" & Rows.Count).End(xlUp).Row, 1)
ActiveSheet.Range("K2", Cells(Range("S" & Rows.Count).End(xlUp).Row, "S")).Copy Cells(Range("A" & Rows.Count).End(xlUp).Row + 1, 1)
End Sub
This more what you're looking for?
Another forum responded with this solution:
Sub TC_Copy_Paste()
Dim TC As Worksheet, RowNum As Long
'
Set TC = Worksheets("TC Data Dump")
On Error Resume Next
With TC.Range("P3").ListObject
RowNum = Application.WorksheetFunction.CountA(.ListColumns(1).DataBodyRange)
.DataBodyRange.Cells(1, 1).Resize(RowNum, 9).Copy Destination:=TC.Cells(Rows.Count, 5).End(xlUp).Offset(1)
End With
With TC.Range("AJ3").ListObject
RowNum = Application.WorksheetFunction.CountA(.ListColumns(1).DataBodyRange)
.DataBodyRange.Cells(1, 1).Resize(RowNum, 9).Copy Destination:=TC.Cells(Rows.Count, 26).End(xlUp).Offset(1)
End With
End Sub
Again, I'm not sure why this works and the other doesn't but I wanted to share the end result.

Loop that replicate my formula until last cell of my row

My aim is to have a formula that fills the empty cells with the previous Q. question, until the last non empty cell (see picture)
The range is the last non empty cell of my row.
For now my code looks like this :
Sub Range_End_Exemple()
Dim cell_target As Range
ActiveCell.FormulaR1C1 = "=+IF(ISBLANK(R[-2]C)=TRUE,RC[-1],R[-2]C)"
Set cell_target = Worksheets("dataset Feedback forms").Range(Cells(1, Columns.Count).End(xlToLeft).Select Type:xlFillDefault
End Sub
Thanks for you help if you have any suggestion.
The sub below is only based the picture you attached.
Sub test()
Dim LastCol As Range
Dim rg As Range
Dim cell As Range
With ActiveSheet
Set LastCol = .Cells(2, Columns.Count).End(xlToLeft).Offset(-1, 0)
Set rg = .Range("D1", LastCol)
For Each cell In rg.SpecialCells(xlCellTypeConstants)
If cell.End(xlToRight).Column = .Columns.Count Then
Range(cell, LastCol).Value = cell.Value
Else
Range(cell, cell.End(xlToRight).Offset(0, -1)).Value = cell.Value
End If
Next
End With
End Sub
The code assumed that nothing is change in "header-2".
The "header-1" will start in cell D1.
How many "type of header-1" is unknown.
The last column used in "header-2" is unknown.
The process:
it get the cell of the last column used in "header-2" then offset the row to -1 then have it as the LastCol variable. The LastCol cell is used to mark the end of "header-1".
then it get the range of the "header-1" into rg variable.
then it loop the cells of the rg which has value,
copy the cell till the last empty cells to the right (before the next header type of "header-1").
since the last header type of "header-1" will have no border, then it will check if the last empty cell column to the right value = the worksheet columns count ... then it use the LastCol variable as the border.
Based on seeing your image attachment, the thing which I'm unable to understand on what you want is : you use a formula for your "header-1" ?
so I'd imagine something like this:
lrow = Cells.Find("*", Cells(1, 1), xlValues, xlPart, xlByColumns, xlPrevious, False).Column ' <-- this gives you the last column blank
nextblank = Cells.Find("", Cells(1, 1), xlFormulas, xlByColumns, xlNext, False).Column ' <-- this gives you the FIRST blank column number
ltr = Split(Cells(1, nextblank - 1).Address, "$")(1) ' <-- this gives you the letter
aux = Range(ltr & "1") ' <-- this is the value you need to copy
After the first nextblank statement you need to use this to iterate
nextblank = Cells.Find("", Cells(1, nextblank), xlFormulas, xlByColumns, xlNext, False).Column
Using those values -> lrow doesn't change, it's your final destination
nextblank,ltr and aux values changes after you copy
Hope it helps!
This will do what you appear to want from your image:
Sub Propagate()
Dim lastCol As Integer
With Worksheets("dataset Feedback forms")
lastCol = .Cells(2, .Columns.Count).End(xlToLeft).Column
With .Cells(1, 4).Resize(1, lastCol - (4 - 1)).SpecialCells(xlCellTypeBlanks)
.FormulaR1C1 = "=RC[-1]"
.Value2 = .Value2
End With
End With
End Sub

How to select entire column except header

I am using below code.
Sub Replace_specific_value()
'declare variables
Dim ws As Worksheet
Dim xcell As Range
Dim Rng As Range
Dim newvalue As Long
Set ws = ActiveSheet
Set Rng = ws.Range("G2:G84449")
'check each cell in a specific range if the criteria is matching and replace it
For Each xcell In Rng
xcell = xcell.Value / 1024 / 1024 / 1024
Next xcell
End Sub
Here i don't want to specify G2:G84449 , how do i tell VBA to pick all value instead of specifying range?
Watch: Excel VBA Introduction Part 5 - Selecting Cells (Range, Cells, Activecell, End, Offset)
Here is the standard way to get the used cell in column G starting at G2:
With ws
Set Rng = .Range("G2", .Cells(.Rows.Count, "G").End(xlUp))
End With
If the last row could be hidden use:
With ws
Set Rng = Intersect(.Range("A1", .UsedRange).Columns("G").Offset(1), .UsedRange)
End With
If Not Rng Is Nothing Then
'Do Something
End If
Reference Column Data Range (w/o Headers)
If you know that the table data starts in the first row of column G, by using the Find method, you can use something like the following (of course you can use the more explicit
With ws.Range("G2:G" & ws.Rows.Count) instead, in the first With statement).
Option Explicit
Sub BytesToGigaBytes()
Const Col As String = "G"
Dim ws As Worksheet: Set ws = ActiveSheet 'improve!
With ws.Columns(Col).Resize(ws.Rows.Count - 1).Offset(1) ' "G2:G1048576"
Dim lCell As Range: Set lCell = .Find("*", , xlFormulas, , , xlPrevious)
If lCell Is Nothing Then Exit Sub ' empty column
With .Resize(lCell.Row - .Row + 1) ' "G2:Glr"
.Value = ws.Evaluate("IFERROR(IF(ISBLANK(" & .Address & "),""""," _
& .Address & "/1024/1024/1024),"""")")
End With
End With
End Sub
Here's a slightly different approach that works for getting multiple columns, as long as your data ends on the same row:
set rng = application.Intersect(activesheet.usedrange, activesheet.usedrange.offset(1), range("G:G"))
This takes the intersection of the used range (the smallest rectangle that holds all data on the sheet, with the used range offset by one row (to exclude the header), with the columns you are interested in.

Reliably get Last Column in Excel with or without Merged Cells

I recently ran into an issue where my get_lcol function returned A1 as the cells in A1:D1 were merged. I adapted my function to account for this, but then I had some other data with cells merged in A1:D1 but another column in G and my function returned D1 so I adjusted it again. The problem is I don't trust it still to work with all data types as its only checking merged cells in row 1.
Take a look at the below data, how can I reliably get the function to return D or 4 regardless of where I move the merged row and/or any other issues I haven't foreseen?
Current Function:
Public Sub Test_LCol()
Debug.Print Get_lCol(ActiveSheet)
End Sub
Public Function Get_lCol(WS As Worksheet) As Integer
Dim sEmpty As Boolean
On Error Resume Next
sEmpty = IsWorksheetEmpty(Worksheets(WS.Name))
If sEmpty = False Then
Get_lCol = WS.Cells.Find(What:="*", after:=[A1], SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
If IsMerged(Cells(1, Get_lCol)) = True Then
If Get_lCol < Cells(1, Get_lCol).MergeArea.Columns.Count Then
Get_lCol = Cells(1, Get_lCol).MergeArea.Columns.Count
End If
End If
Else
Get_lCol = 1
End If
End Function
Update:
Try this data w/ function:
This is a twist on the classic "Find Last Cell" problem
To state the aim:
find the column number of the right most cell containing data
consider merged cell areas that extend beyond other cells containing data. Return the right most column of a merged area should that extend beyond other data.
exclude formatted but empty cells and merged areas
The approach:
Use Range.Find to locate the last data cell
If the last column of the Used Range = Found last data cell column, return that
Else, loop from the last column of the Used Range back to the found data cell column
test for data in that column (.Count > 0), if true return that
test for merged cells in that column (IsNull(.MergeCells))
if found, loop to find the merged area
test the left most cell of the merged area for data
if found return the search column
Note
this may still be vulnerable to other "Last data" issues, eg Autofilter, Hidden rows/columns etc. I haven't tested those cases.
Has the advantage of limiting the search for merged cells to the relavent right most columns
Function MyLastCol(ws As Worksheet) As Long
Dim ur As Range
Dim lastcell As Range
Dim col As Long
Dim urCol As Range
Dim urCell As Range
Set ur = ws.UsedRange
Set lastcell = ws.Cells.Find("*", ws.Cells(1, 1), xlFormulas, , xlByColumns, xlPrevious)
For col = ur.Columns.Count To lastcell.Column - ur.Column + 2 Step -1
Set urCol = ur.Columns(col)
If Application.CountA(urCol) > 0 Then
MyLastCol = urCol.Column
Exit Function
End If
If IsNull(urCol.MergeCells) Then
For Each urCell In urCol.Cells
If urCell.MergeCells Then
If Not IsEmpty(urCell.MergeArea.Cells(1, 1)) Then
MyLastCol = urCol.Column
Exit Function
End If
End If
Next
End If
Next
MyLastCol = lastcell.Column
End Function
#Toddleson got me on the right track, here is what I ended with:
Public Sub Test_LCol()
Debug.Print Get_lCol(ActiveSheet)
End Sub
Public Function Get_lCol(WS As Worksheet) As Integer
On Error Resume Next
If Not IsWorksheetEmpty(WS) Then
Get_lCol = WS.Cells.Find(What:="*", after:=[A1], SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
Dim Cell As Range
For Each Cell In WS.UsedRange
If Cell.MergeCells Then
With Cell.MergeArea
If .Cells(.Cells.Count).Column > Get_lCol Then Get_lCol = .Cells(.Cells.Count).Column
End With
End If
Next Cell
Else
Get_lCol = 1
End If
End Function
The Find Method Backed Up by the UsedRange Property: What?
Talking about wasting time...
Option Explicit
Function GetLastColumn( _
ByVal ws As Worksheet) _
As Long
If ws Is Nothing Then Exit Function
' Using the 'Find' method:
'If ws.AutoFilterMode Then ws.AutoFilterMode = False ' (total paranoia)
Dim lcCell As Range
Set lcCell = ws.Cells.Find("*", , xlFormulas, , xlByColumns, xlPrevious)
If Not lcCell Is Nothing Then
GetLastColumn = lcCell.Column
End If
Debug.Print "After 'Find': " & GetLastColumn
' Using the 'UsedRange' property (paranoia):
Dim rg As Range: Set rg = ws.UsedRange
Dim clColumn As Long: clColumn = rg.Columns.Count + rg.Column - 1
If clColumn > GetLastColumn Then
If rg.Address(0, 0) = "A1" Then
If IsEmpty(rg) Then
Exit Function
End If
End If
GetLastColumn = clColumn
'Else ' clColumn is not gt GetLastColumn
End If
Debug.Print "Final (if not 0): " & GetLastColumn
End Function
Sub GetLastColumnTEST()
Debug.Print "Sub Result: " & GetLastColumn(Sheet1)
Debug.Print Sheet1.UsedRange.Address(0, 0)
End Sub
' It works for a few (?) cells, otherwise it returns 'Null'.
Sub TestMergeCells() ' Useless?! Could someone confirm.
Debug.Print Sheet1.Cells.MergeCells ' Null for sure
Debug.Print Sheet1.UsedRange.MergeCells
End Sub

VBA Excel select content after the character occurrence

I want to select the content of my worksheet after the character occurrence in the row.
The code I have been using so far selects all the stuff after the offset.
Sub Selection ()
Dim Target_Start As Range, Target_End As Range
Dim n as long
Set Target_Start = work.Cells.Find("X", SearchOrder:=xlByColumns).Offset(1)
Set Target_End = Target_Start.End(xlDown).End(xlToRight)
work.Range(Target_Start, Target_End).Select
'Selection.EntireRow.Clear
End Sub
What should I alter in my code?
Select Used Range After a Cell
If you want to allow a lower-case "X" then replace True with False (MatchCase).
Note that this solution will include row 15 in your image which may be only formatted (borders, no values), because we are using Used Range. If you don't like that, you will have to use another way to define the range.
Option Explicit
Sub selectAfter()
Const sString As String = "X"
With work.UsedRange
Dim rg As Range
Set rg = .Find(sString, .Cells(.Rows.Count, .Columns.Count), _
xlFormulas, xlWhole, xlByRows, , True)
If Not rg Is Nothing Then
Dim Offs As Long: Offs = rg.Row - .Row + 1
Set rg = .Resize(.Rows.Count - Offs).Offset(Offs)
rg.Select
End If
End With
End Sub

Resources