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
Related
Problem
I have a sheet in which first i have to filter the last column.
For each unique value present in last column, I have to copy data from first column to last-1 column
Then I have to add new sheet and need to paste this data in new sheet.
I repeat same process 3 for each unique value present in last column. Like in last column is of language. so first sort this column. then copy and paste data for each language in new sheets.
Sub LoopThroughAllItemsInFilters()
Range("G2", Range("G" & Cells(Rows.Count, 1).End(xlUp).Row)).Select
Selection.Copy
Columns("L").Select
ActiveSheet.Paste
ActiveSheet.Range("$L$1:$L$10000").RemoveDuplicates Columns:=1, Header:=xlYes
Dim ArrayDictionaryofItems As Object, Items As Variant, i As Long, Item As Variant
Set ArrayDictionaryofItems = CreateObject("Scripting.Dictionary")
With ActiveSheet
'show autofilter if not already shown on all rows
If Not .AutoFilterMode Then .UsedRange.AutoFilter
If .Cells.AutoFilter Then .Cells.AutoFilter
'Create list of unique items in column G that get filled into ArrayDictionaryofItems
Dim annoying As Double
If Range("G3").Value <> "" Then
annoying = 2
Items = Range(.Range("L2"), .Cells(Rows.Count, "L").End(xlUp))
'Fills ArrayDictionaryofItems to the UBOUND (max) count of unique items in column L.
For i = 1 To UBound(Items, 1)
ArrayDictionaryofItems(Items(i, 1)) = 1
Next
Else
Item = Range("G2").Value
annoying = 1
End If
'Filter multiple items if annoying is set to equal 2 because G3 is blank
If annoying = 2 Then
For i = 1 To UBound(Items, 1)
Sheets.Add After:=Sheets(i)
Next i
Sheets("DEFAULTERS").Select
Dim x As Double
x = 2
For Each Item In ArrayDictionaryofItems.keys
erow = ActiveSheet.Cells(Rows.Count, 2).End(xlUp).Row
'autofilter on column b with this driver
.UsedRange.AutoFilter field:=7, Criteria1:=Item
Columns("A:G").Select
Selection.SpecialCells(xlCellTypeVisible).Select
Selection.Copy
Sheets(x).Select
Columns("A:G").Select
ActiveSheet.Paste
Sheets("DEFAULTERS").Select
x = x + 1
Next Item
GoTo LINE99:
End If
'Filter a single item in column since G3 is blank and there is only one item in column G to filter
If annoying = 1 Then
Sheets.Add After:=ActiveSheet
Sheets("DEFAULTERS").Select
Item = Range("G2").Value
.UsedRange.AutoFilter field:=7, Criteria1:=Item
End If
Columns("A:G").Select
Selection.SpecialCells(xlCellTypeVisible).Select
Selection.Copy
Sheets(2).Select
Columns("A:G").Select
ActiveSheet.Paste
Sheets("DEFAULTERS").Select
End With
LINE99:
With ActiveSheet
If .AutoFilterMode Then .UsedRange.AutoFilter
End With
End Sub
I have to preface this by saying I am below the lowest level of novice when it comes to VBA. I currently have a single column of data in excel where information about companies is stored in groups of three rows as you descend down the column. The data is grouped as follows (no empty rows between the data):
CompanyA
www.CompanyA.com
CompanyA location
CompanyB
www.CompanyB.com
CompanyB location... etc.
I need to create a code that will copy the cell below, paste it to cell to the right, then delete the row below. Then copy the cell that is now below, and paste it two to the right, then select the next cell down and repeat for the next three row dataset. I've included my terrible first draft below if this helps explain my thinking. Any help would be very much appreciated. Thank you!
Sub Clean()
Do Until IsEmpty(ActiveCell.Value)
Range("A1").Activate
Selection.Offset(1, 0).Copy
Selection.Offset(0, 1).Paste
ActiveCell.Offset(1, 0).EntireRow.Delete xlShiftUp
Selection.Offset(1, 0).Copy
Selection.Offset(0, 2).Paste
ActiveCell.Offset(1, 0).EntireRow.Delete xlShiftUp
ActiveCell.Offset(1, 0).Select
Loop
End Sub
This could help you do what you want. Not the best solution out there but this will loop through all the cells slightly faster than what you have done.
Sub test()
Dim lRow As Long, i As Long
Dim ws As Worksheet
Dim RowsToDelete As Range
Set ws = ActiveSheet
With ws
lRow = .Cells(.Rows.Count, 1).End(xlUp).Row ' Get the last row
For i = lRow To 1 Step -3
.Cells(i - 2, 3) = .Cells(i, 1)
.Cells(i - 2, 2) = .Cells(i - 1, 1)
If RowsToDelete Is Nothing Then 'first 2 rows to be deleted
Set RowsToDelete = Range(.Rows(i).EntireRow, .Rows(i - 1).EntireRow)
Else 'append more rows with union
Set RowsToDelete = Application.Union(RowsToDelete, .Rows(i).EntireRow, .Rows(i - 1).EntireRow)
End If
Next i
If Not RowsToDelete Is Nothing Then 'if there is something to be deleted
RowsToDelete.Delete
End If
End With
End Sub
You should try to avoid using ActiveCell and Selection in most cases. User input while the code is running can mess up your position and yields unpredictable results.
Its best to pull the data into an array, process your changes and output the data. This method also happens to be faster as you're not constantly reading and writing data to the sheet.
Something like the below will perform better for large data sets and will not be affected by user input during runtime:
Sub GatherCompanyData()
Dim Temp As Variant, Target As Range
Dim x As Long, c As Long, MyOutput As Variant
'First cell containing data [UPDATE THIS AS NEEDED]
Set Target = Sheets("SHEET NAME HERE").Range("A1")
'Get all the data in specified column
With Target.Parent
Temp = .Range(Target.Cells(1, 1).Address, .Cells(.Rows.Count, Target.Column).End(xlUp).Address).Value
End With
'Build Output Data
ReDim MyOutput(1 To Int(UBound(Temp, 1) / 3), 1 To 3)
For x = 3 To UBound(Temp, 1) Step 3
c = c + 1
MyOutput(c, 1) = Temp(x - 2, 1)
MyOutput(c, 2) = Temp(x - 1, 1)
MyOutput(c, 3) = Temp(x, 1)
Next x
'Clear existing data and output new data
Target.Value = Empty
Target.Resize(c, 3).Value = MyOutput
End Sub
I think I actually just figured it out. I'm sure this isn't the most elegant solution but it works. Curious if anyone has a better way of solving this. Thanks!
Sub Clean()
Range("A1").Activate
Do Until IsEmpty(ActiveCell.Value)
Selection.Offset(1, 0).Copy
Selection.Offset(0, 1).Select
ActiveCell.PasteSpecial xlPasteAll
ActiveCell.Offset(1, 0).EntireRow.Delete xlShiftUp
Selection.Offset(1, -1).Select
ActiveCell.Copy
Selection.Offset(-1, 2).Select
ActiveCell.PasteSpecial xlPasteAll
ActiveCell.Offset(1, 0).EntireRow.Delete xlShiftUp
Selection.Offset(1, -2).Select
Loop
End Sub
Can someone help me modify this code so that it can reference the data in cell A6 and paste to the sheet named after that data.
I already have a working macro for pasting data from a cover sheet to individual worksheets, each day, and without overwriting previously populated cells (See below).
The issue is that the code is too specific and is not easily manipulated when new rows are introduced to the "Balancer" cover-sheet. Here is an example of the current code:
Sub pastetosheet()
r = 1
Sheets("Balancer").Range("B2").Copy
Sheets("X9X9USDFEDT6").Range("C35").End(xlUp).Offset(r, 0).PasteSpecial _
paste:=xlPasteValues
Application.CutCopyMode = False
Sheets("Balancer").Range("D2").Copy
Sheets("X9X9USDFEDT6").Range("D35").End(xlUp).Offset(r, 0).PasteSpecial _
paste:=xlPasteValues
Application.CutCopyMode = False
Sheets("Balancer").Range("F2").Copy
Sheets("X9X9USDFEDT6").Range("F35").End(xlUp).Offset(r, 0).PasteSpecial _
paste:=xlPasteValues
Application.CutCopyMode = False
Sheets("Balancer").Range("G2").Copy
Sheets("X9X9USDFEDT6").Range("H35").End(xlUp).Offset(r, 0).PasteSpecial _
paste:=xlPasteValues
Application.CutCopyMode = False
End Sub
I want the code to copy data in Range "B6" on the "Balancer" tab, then reference the data in the cell to the left (A6 in this case) to find out which sheet it will be pasting to. Then use the paste rules already in place from the current code.
If each row specifies its own destination sheet in column A, this should do:
Sub pasteToSheetOfA()
Dim r As Long, t As Range
With Sheets("Balancer")
For r = 1 To .Range("B1000000").End(xlUp).Row ' for all rows of column B
' get the target sheet specified in column A, goto beyond last cell in C of this sheet
Set t = Sheets(.Range("A" & r).value).Range("C1000000").End(xlUp).Offset(1)
' now copy the cells of the row according to the rules of the OP
t.value = .Cells(r, "B").value
t.Offset(,1).value = .Cells(r, "D").value
t.Offset(,3).value = .Cells(r, "F").value
t.Offset(,5).value = .Cells(r, "G").value
Next
End With
End Sub
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
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