Excel Macro to add COUNTA to new top row - excel

I have an Excel 2013 worksheet where each column has a header row, and then the word "DIRECT" in some or all of the cells. No other data exists in the columns, just "DIRECT" or blanks. No columns are blank, they all have "DIRECT" at least once.
I'm looking for a macro that does the following:
Adds a new top row
Ignores the original header row, but gets a count of the cells with "DIRECT" in them
Puts that number in the corresponding new top cell for each column
Does the above actions for each column in the worksheet
Works regardless of the last column or row with data (I have to run this on several different-sized worksheets)
I recorded a macro that gets close, but it has two problems:
It adds the COUNTA data out to the last row of the workbook, which isn't needed (the populated columns will be a couple hundred, not thousands)
It references a specific cell range, so could cut off data for sheets with more rows
Sub AddColumnCountsRecorded()
'
' AddColumnCounts Macro
'
'
Rows("1:1").Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Range("J1").Select
ActiveCell.FormulaR1C1 = "=COUNTA(R[2]C:R[15]C)"
Range("J1").Select
Selection.Copy
Range(Selection, Selection.End(xlToRight)).Select
ActiveSheet.Paste
End Sub
If it helps:
Column "A" can determine the last row where data could be (that's the "username" column", so no blanks there) - although this last row will also change from sheet to sheet.
Row 2 (the header row) can determine the last column where data could be - it has no blank columns; in each column, at least one cell will have the word "DIRECT".
Any advice on editing the existing macro or concocting a new one from scratch would be greatly appreciated!
Thanks!
UPDATE:
Much thanks to Scott, here's what I ended up with - this adds the non-blank cell count to the active worksheet and stops at the last row with data in it. I just call it directly, without the 2nd section of code proposed below:
Sub AddColumnCountsRecorded()
With ActiveSheet
.Rows("1:1").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Dim lRow As Long, lCol As Long
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
lCol = .Cells(2, .Columns.Count).End(xlToLeft).Column
.Range(.Cells(1, 2), .Cells(1, lCol)).FormulaR1C1 = "=COUNTA(R[2]C:R[" & lRow & "]C)"
End With
End Sub

Give this a shot. I made a separate sub that you can pass the worksheet reference too.
Sub AddColumnCountsRecorded(ws As Worksheet)
With ws
.Rows("1:1").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Dim lRow As Long, lCol As Long
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
lCol = .Cells(2, .Columns.Count).End(xlToLeft).Column
.Range(.Cells(1, 2), .Cells(1, lCol)).FormulaR1C1 = "=COUNTA(R[2]C:R[" & lRow & "]C)"
End With
End Sub
Call it like this:
Sub ColumnCount()
AddColumnCountsRecorded Worksheets("Sheet1")
End Sub

Related

VBA - How to copy and data from a worksheet in a certain condition to the last worksheet

I'm new with VBA and I am trying to create a macro for work to make everyone's life easier. My goal is to copy rows (or just copy the data in the first column when the second column is "0") from one worksheet named "Bulk Update" with the condition of column B having the value "0" to the last worksheet, at the bottom of the worksheet after the data. I don't know how to reference the last worksheet name. Here is the code that I made (please don't judge me as I am still new and googling around), which I know is completely wrong...
Public Sub CNPPrevOOS()
Worksheets("Bulk Update").Select
a = Worksheets("Bulk Update").Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To a
If Worksheets("Bulk Update").Cells(i, 2).Value = "0" Then
Selection.Copy
ThisWorkbook.Worksheets(ThisWorkbook.Sheets.Count).Range("A1").Value = 100
Range("A30000").Select
Selection.End(xlUp).Select
ActiveCell.Offset(1, 0).Select
ActiveSheet.Paste
End If
Next
End Sub
You could try the below code.
The data is being filtered for Column 2 = 0. Only those rows are copied and pasted in the last worksheet
Public Sub CNPPrevOOS()
Worksheets("Bulk Update").Select
a = Worksheets("Bulk Update").Cells(Rows.Count, 1).End(xlUp).Row
'Filters the data where column 2 = 0
ActiveSheet.Range(Cells(1, 1), Cells(a, 2)).AutoFilter Field:=2, Criteria1:="0", Operator:=xlFilterValues
'Select only the filtered cells and copy
Range(Cells(2, 1), Cells(a, 1)).SpecialCells(xlCellTypeVisible).Select
Selection.Copy
ThisWorkbook.Worksheets(ThisWorkbook.Sheets.Count).Select
ActiveSheet.Paste Destination:=Cells(Cells(Rows.Count, 1).End(xlUp).Row + 1, 1)
End Sub

Merge ranges in one column

I have the following script copying a range "F30:F37", "G30:G37" from Sheet 1. I am trying to select both ranges into Sheet2 starting with ROW G101. However, only Sheet 1 "G30:G37" data copies into Sheet 2, ROW G101. What could be the issue, would you be able to simplify my data pull? Listed below, Macro:
Dim LastRow As Long
Dim SHEET2 As Worksheet
Set Results = Sheets("SHEET2")
LastRow = Results.Cells(Results.Rows.Count, "Z").End(xlUp).Row
Range("F30:F37").Copy
Results.Range("G" & LastRow + 101).PasteSpecial xlPasteValues
Range("G30:G37").Copy
Results.Range("G" & LastRow + 101).PasteSpecial xlPasteValues
Application.DataEntryMode = False
End Sub
This is how column with rows display, please note, row G has no header:
This would be my result:
My result would look like the second image, sheet 2
First off, Results is a variable that should be in your Dim statement, not "Sheet2". Secondly, you are pasting over the first paste. If you want row 101 for the first, paste in row 101. Then find the last row and paste the info below. And lastly, you want Application.CutCopyMode to take you out of the copy/paste.
Sub CopyData()
Dim LastRow As Long
Dim Results As Worksheet
Set Results = Sheets("SHEET2")
Range("F30:F37").Copy
Results.Range("G101").PasteSpecial xlPasteValues
LastRow = Results.Cells(Results.Rows.Count, "G").End(xlUp).Row
Range("G30:G37").Copy
Results.Range("G" & LastRow).PasteSpecial xlPasteValues
Application.CutCopyMode = False
End Sub

Creating a Loop Through 4 worksheets Paste not working

Hi guys I'm doing a course for Udemy and the lecturer unfortunately has not been the most responsive.
I have a workbook called QuarterlyReport and 5 sheets.
East Records
West Records
North Records
South Records
Yearly Report
My code formats the Worksheets 1-4 and then copy pastes the information to Yearly Report on the last unused row. For some reason, the code is only pasting South Records. My goal is to copy every single sheet 1 - 4 and paste it onto the fifth sheet "YEARLY REPORT".
Public Sub Finalreportloop()
Dim i As Integer
i = 1
Do While i <= Worksheets.Count - 1
Worksheets(i).Select
AddHeaders
FormatData
AutoSum
' copy the current data
Range("A1").Select
Selection.CurrentRegion.Select
Selection.Copy
' select the final report WS'
Worksheets("yearly report").Select
'find the empty cells
LastRow = Sheets(i).Range("A" & Sheets(i).Rows.Count).End(xlUp).Row
'paste the new data in
ActiveSheet.Paste
i = i + 1
Loop
End Sub
The Addheaders, FormatData and AutoSum are in reference to other Modules I've created. Thank you everyone!
The code determines the last row of the sheet that you are copying from, but you don't do anything with that information. Instead, it just pastes into the active sheet and overwrites the data posted in the last loop instance. Hence it looks as if it is only copying/pasting the last data set.
You need to find the last row in the Yearly sheet, then paste the data below that.
You coudld try one of the methods below:
Option Explicit
Sub test()
Dim ws As Worksheet
Dim wsLastRow As Long, wsLastColumn As Long, yrLastRow As Long
Dim rngCopy As Range
For Each ws In ThisWorkbook.Worksheets
If ws.Name <> "YEARLY REPORT" Then
With ws
'Method 1 - You can siply used range
' .UsedRange.Copy
'Method 2 - You can calculate LastColumn & LastRow and create the range
wsLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row '<- Find last row of column A.
wsLastColumn = .Cells(1, .Columns.Count).End(xlToLeft).Column '<- Find the last column of row 1.
Set rngCopy = .Range(Cells(1, 1), Cells(wsLastRow, wsLastColumn)) '<- Create the range to be copy.
rngCopy.Copy
End With
With ThisWorkbook.Worksheets("YEARLY REPORT")
yrLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row '<- Find last row of column A.
.Range("A" & yrLastRow + 1).PasteSpecial xlPasteValues
End With
End If
Application.CutCopyMode = False
Next ws
End Sub

VBA Macro to AutoFill Right until Last Column

I have a report that is automatically pulled that requires Sums to be added at the end of certain columns. The report remains static from Column A-R but the amount of columns as of S can be as few as 1 or go up until 52. The amount of rows are never static. I already know how to find the last row and my sums need to start at column J but when I try to autofill to the right to the last column that contains data (on the same row I have summed J), it spits back an error or doesn't work. Anyone know how to do this? This is what I have for code thus far.
Sub TV_Buysheet()
'
' Macro1 Macro
'
Range("J1").Select
FIRST_ROW = ActiveCell.Row
Selection.End(xlDown).Select
LAST_ROW = ActiveCell.Row
Selection.Offset(2, 0).Select
ActiveCell.FormulaR1C1 = "=SUM(R[" & FIRST_ROW - LAST_ROW - 2 & "]C:R[-2]C)"
Dim lastCol As Long
lastCol = Cells(2, Columns.Count).End(xlToLeft).Column
ActiveCell.AutoFill Destination:=Range(ActiveCell, lastCol), Type:=xlFillDefault
End Sub
Just missing the line of code that autofills to the last column...
To find the last column, the following should work
Dim lngLastColumn As Long
lngLastColumn = Cells.Find(What:="*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
Range(Activecell, Cells(Activecell.Row, lngLastColumn)).FillRight

How would you delete rows in excel such that Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select will not select the now empty rows

The issue is that I have a function that deletes rows containing specific text:
Sub DeleteRowsContaining(text As String)
Dim Firstrow As Long
Dim Lastrow As Long
Dim Lrow As Long
With ActiveSheet
'Set the first and last row to loop through
Firstrow = .UsedRange.Cells(2).Row
Lastrow = .UsedRange.Rows(.UsedRange.Rows.Count).Row
'We loop from Lastrow to Firstrow (bottom to top)
For Lrow = Lastrow To Firstrow Step -1
'We check the values in the A column
With .Cells(Lrow, "A")
If Not IsError(.Value) Then
If .Value = text Then .EntireRow.Delete
'This will delete each row with the Value of text
'in Column A, case sensitive.
End If
End With
Next Lrow
End With
End Sub
After executing this code block I then would like to select the remaining text, however, any rows that were deleted from the end of a column still count when using the
Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
command. The real issue is the error that happens when using the next command which is
Selection.End(xlDown).Offset(1, 0).Select
When using that command, if you have more than two empty rows selected, an error will be thrown. At this point I am at a loss, as all the ways that I can easily and dynamically check for the end of my data range are returning the location of a blank cell.
I am not sure if there is another way to delete a row that does not leave a cell selectable as if it had data, or if there is a way to trim the empty rows from a selection when excel seems to believe that the rows have something there.
Once you have completed deleting unwanted rows, to select the rows that remain run:
Sub SelectTheRest()
Dim N As Long
N = Cells(Rows.Count, "A").End(xlUp).Row
Range("A1:A" & N).EntireRow.Select
End Sub

Resources