I have a macro which is part of a few, however this is the first to tidy up sheet before running
To determine the column and table to tidy I am trying to find the last empty value and create a column and table range to use as variable throughout my modules. However failing at an early bit whether I choose cells C4 or C5 or refer to them in R1C1 style it breaks as if cells were empty however they are not.
It breaks at
LRow = ws.Cells(Rows.Count, C5).End(xlUp).Row
Unsure how to get it to proceed.
Sub Tidy()
'
' Tidy Macro
'
'
Dim table_1 As Long
Dim table_2 As Long
Dim col_len, table_len As Range
Dim LRow As Long
Dim ws As Worksheet
Set ws = ThisWorkbook.ActiveSheet
LRow = ws.Cells(Rows.Count, C5).End(xlUp).Row
Set col_len = ws.Range("C4:C" & Cells(LRow).Address(False, False))
Set table_len = ws.Range("A4:F" & Cells(LRow).Address(False, False))
table_2 = Worksheets("DumpSheet").Cells(Row.Count, R5C10).End(xlUp).Row
Range("A5").Select
ActiveCell.FormulaR1C1 = "=R1C1"
Range("A5").Select
Selection.AutoFill Destination:=Range("A5:A" & col_len)
Range(table_len).Select
Selection.Copy
Range("H5").Select
ActiveSheet.Paste
Range("B5").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = "=R[-4]C"
Range("B5").Select
ActiveCell.FormulaR1C1 = "=R1C2"
Range("B5").Select
Selection.AutoFill Destination:=Range("B5:B" & col_len)
Range("B5:B" & table_1).Select
Range("I5").Select
ActiveCell.FormulaR1C1 = "=R1C9"
Range("I5").Select
Selection.AutoFill Destination:=Range("I5:I29")
Range("I5:I" & table_2).Select
End Sub
C5 is being treated as a variable that hasn't been assigned. It is not a cell reference. You're looking for something more like:
LRow = ws.Cells(ws.Rows.Count, 3).End(xlUp).Row
Related
This is my first time asking a question on here. I have dug through similar questions, but have had no luck yet in resolving this quandary. I appreciate any help you can give me.
In the data set I am working with, I am looking to delete any rows that contain the word "Bench" in column R. I already have the rest of the worksheet running and have the Lrow value set as the last row.
I was first successful using the .Setfilter, selecting the range, and using EntireRow.Delete. But this ended up deleting the entire dataset if there were no rows to select.
To summarize the ask: Looking in Range("R2":"R" & Lrow), find all cells containing the text "Bench", then Delete the row.
Thank you!
Here is the entire VBA as sits right now (this bit is near the bottom):
Sub BE_Time_to_Fill()
'
' BE_Time_to_Fill Macro
'
Dim StartCell As Range
Dim RangeName As String
Dim myValue As Variant
Set StartCell = Range("A1")
myValue = InputBox("Enter Date: YY-MMM")
'Select Range
StartCell.CurrentRegion.Select
RangeName = "Dataset"
Dim LRow As Long
Dim lCol As Long
'Find the last non-blank cell in column A(1)
LRow = Cells(Rows.Count, 1).End(xlUp).Row
'Find the last non-blank cell in row 1
lCol = Cells(1, Columns.Count).End(xlToLeft).Column
Columns("J:J").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Range("J1").FormulaR1C1 = "Time to Fill"
Range("J2", "J" & LRow).FormulaR1C1 = "=RC[1]+RC[2]"
Range("F1").Select
Range("F1").FormulaR1C1 = "Job Code"
Range("F1", "F" & LRow).AutoFilter 1, ""
Range("F2", "F" & LRow).FormulaR1C1 = "=RC[-1]"
[F1].AutoFilter
Range("M1").FormulaR1C1 = "Source Time"
Columns("N:N").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Range("N1").FormulaR1C1 = "Cycle Time"
Range("N2", "N" & LRow).FormulaR1C1 = "=IMSUB(RC[1],RC[-1])"
Columns("A:A").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Range("A1").FormulaR1C1 = "Application ID"
Range("A2", "A" & LRow).FormulaR1C1 = "=CONCATENATE(RC[1],RC[4])"
Cells.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Columns("B:B").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Range("B1").FormulaR1C1 = "Timeframe"
Range("B2", "B" & LRow).Value = myValue
Dim rng As Range
Dim DelRng As Range
Set DelRng = Range("R2:R" & LRow)
For Each rng In DelRng
If rng.Value = "*Bench" Then
rng.EntireRow.Delete
ElseIf rng.Value <> "*Bench" Then
End If
Next
Range("G:H,M:N").Delete Shift:=xlToLeft
Range("A1").Select
End Sub
Without seeing what code you have we can't help update it. But from your question the below might help.
If you're using a loop you'll need to include what to do if the set conditions aren't met. See example:
Sub example()
Dim rng As Range, DelRng As Range
Dim LastRow As Long
LRow = Range("R" & Rows.Count).End(xlUp).Row 'test for last filled row in column R
Set DelRng = Range("R1:R" & LRow) 'sets your range
For Each rng In DelRng
'change this value to match whatever you want to find. make sure this is entered as ALL CAPS and without spaces
If UCase(WorksheetFunction.Substitute(rng.Value, " ", "")) = "GEM/BENCH" Then
rng.EntireRow.Delete
ElseIf UCase(WorksheetFunction.Substitute(rng.Value, " ", "")) <> "GEM/BENCH" Then 'if loop can't find anything it will just exit
End If
Next
End Sub
I have two sheets. One has the complete data and the other is based on the filter applied on the first sheet.
Name of the data sheet : Data
Name of the filtered Sheet : Hoky
I am just taking a small portion of data for simplicity. MY objective is to copy the data from Data Sheet, based on the filter. I have a macro which somehow works but its hard-coded and is a recorded macro.
My problems are:
The number of rows is different everytime. (manual effort)
Columns are not in order.
Sub TESTTHIS()
'
' TESTTHIS Macro
'
'FILTER
Range("F2").Select
Selection.AutoFilter
ActiveSheet.Range("$B$2:$F$12").AutoFilter Field:=5, Criteria1:="hockey"
'Data Selection and Copy
Range("C3").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("Hockey").Select
Range("E3").Select
ActiveSheet.Paste
Sheets("Data").Select
Range("D3").Select
Range(Selection, Selection.End(xlDown)).Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Hockey").Select
Range("D3").Select
ActiveSheet.Paste
Sheets("Data").Select
Range("E3").Select
Range(Selection, Selection.End(xlDown)).Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Hockey").Select
Range("C3").Select
ActiveSheet.Paste
End Sub
Best way of doing it
Below code is to copy the visible data in DBExtract sheet, and paste it into duplicateRecords sheet, with only filtered values. Range selected by me is the maximum range that can be occupied by my data. You can change it as per your need.
Sub selectVisibleRange()
Dim DbExtract, DuplicateRecords As Worksheet
Set DbExtract = ThisWorkbook.Sheets("Export Worksheet")
Set DuplicateRecords = ThisWorkbook.Sheets("DuplicateRecords")
DbExtract.Range("A1:BF9999").SpecialCells(xlCellTypeVisible).Copy
DuplicateRecords.Cells(1, 1).PasteSpecial
End Sub
I suggest you do it a different way.
In the following code I set as a Range the column with the sports name F and loop through each cell of it, check if it is "hockey" and if yes I insert the values in the other sheet one by one, by using Offset.
I do not think it is very complicated and even if you are just learning VBA, you should probably be able to understand every step. Please let me know if you need some clarification
Sub TestThat()
'Declare the variables
Dim DataSh As Worksheet
Dim HokySh As Worksheet
Dim SportsRange As Range
Dim rCell As Range
Dim i As Long
'Set the variables
Set DataSh = ThisWorkbook.Sheets("Data")
Set HokySh = ThisWorkbook.Sheets("Hoky")
Set SportsRange = DataSh.Range(DataSh.Cells(3, 6), DataSh.Cells(Rows.Count, 6).End(xlUp))
'I went from the cell row3/column6 (or F3) and go down until the last non empty cell
i = 2
For Each rCell In SportsRange 'loop through each cell in the range
If rCell = "hockey" Then 'check if the cell is equal to "hockey"
i = i + 1 'Row number (+1 everytime I found another "hockey")
HokySh.Cells(i, 2) = i - 2 'S No.
HokySh.Cells(i, 3) = rCell.Offset(0, -1) 'School
HokySh.Cells(i, 4) = rCell.Offset(0, -2) 'Background
HokySh.Cells(i, 5) = rCell.Offset(0, -3) 'Age
End If
Next rCell
End Sub
When i need to copy data from filtered table i use range.SpecialCells(xlCellTypeVisible).copy. Where the range is range of all data (without a filter).
Example:
Sub copy()
'source worksheet
dim ws as Worksheet
set ws = Application.Worksheets("Data")' set you source worksheet here
dim data_end_row_number as Integer
data_end_row_number = ws.Range("B3").End(XlDown).Row.Number
'enable filter
ws.Range("B2:F2").AutoFilter Field:=2, Criteria1:="hockey", VisibleDropDown:=True
ws.Range("B3:F" & data_end_row_number).SpecialCells(xlCellTypeVisible).Copy
Application.Worksheets("Hoky").Range("B3").Paste
'You have to add headers to Hoky worksheet
end sub
it needs to be .Row.count not Row.Number?
That's what I used and it works fine
Sub TransfersToCleared()
Dim ws As Worksheet
Dim LastRow As Long
Set ws = Application.Worksheets("Export (2)") 'Data Source
LastRow = Range("A" & Rows.Count).End(xlUp).Row
ws.Range("A2:AB" & LastRow).SpecialCells(xlCellTypeVisible).Copy
I'm taking data that is listed across multiple columns and putting it into a single column (A). If there is data in column B, it grabs that data, sticks it at the end of the data in column A, then goes back and deletes the now empty column B, which moves all the other columns over one so now there is data in column B again, up until the point there are no more columns of data except for column A. The way I'm doing this currently is by listing multiple blocks of the same code below which is not efficient obviously and sooner or later the code will break. Any advice is appreciated!!
Range("B1").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Cut
Range("A1").Select
Selection.End(xlDown).Select
ActiveCell.Offset(1, 0).Range("A1").Select
ActiveSheet.Paste
Selection.End(xlUp).Select
ActiveCell.Offset(0, 1).Columns("A:A").EntireColumn.Select
Selection.Delete Shift:=xlToLeft
ActiveCell.Offset(0, -1).Range("A1").Select
I like Christmas007's answer. I wanted to share this solution too:
Sub MoveIt()
Dim mysht As Worksheet
Set mysht = ActiveSheet
Set myrng = mysht.UsedRange
nextrow = mysht.Cells(mysht.Rows.Count, 1).End(xlUp).Row
For i = 2 To myrng.Columns.Count
lastColrow = myrng.Cells(mysht.Rows.Count, i).End(xlUp).Row
If lastColrow <> 1 Or myrng.Cells(1, i) <> "" Then
For j = 1 To lastColrow
nextrow = nextrow + 1
mysht.Cells(nextrow, 1) = myrng.Cells(j, i)
Next j
End If
Next i
Range(myrng.Columns(2), myrng.Columns(myrng.Columns.Count)).Clear
End Sub
I like it because it doesn't use the copy, paste, and delete functions. In my experience these functions start to cause the macro to drag if you are dealing with big workbooks and they also require that the sheet is activated.
There is a pretty simple way to do this:
Sub MoveIt()
Dim LastRow As Long
Dim ws1 as Worksheet
Set ws1 = Sheets("Name of Sheet")
Do While (ws1.Range("B1").Value <> "")
LastRow = ws1.Range("A" & ws1.Rows.Count).End(xlUp).Row + 1
ws1.Range("B1:B" & ws1.Range("B" & ws1.Rows.Count).End(xlUp).Row).Copy
ws1.Range("A" & LastRow).PasteSpecial
ws1.Range("B1").EntireColumn.Delete xlToLeft
Loop
End Sub
I'm new with vba and have created a macro that copy columns from all worksheets (sourceSheet) in the workbook over to Sheet1 (destSheet) and also creating an header in Sheet1 (destSheet).
It's working fine when I'm running it with columns in order, like A to D (A:D) but I want to copy the columns
A from sourceSheet to B in destSheet
B from sourceSheet to C in destSheet
C from sourceSheet to D in destSheet
D from sourceSheet to E in destSheet
E from sourceSheet to G in destSheet
J from sourceSheet to H in destSheet
K from sourceSheet to I in destSheet
O from sourceSheet to J in destSheet
I also want to insert a blank row in F in destSheet.
Someone that can help me with this ?
Sub Test()
Dim sourceSheet As Worksheet 'Define Source Sheet
Dim sourceRows As Integer 'Define Source Row
Dim destSheet As Worksheet 'Define Destination Sheet
Dim lastRow As Integer 'Define Last Row
Dim sourceMaxRows As Integer 'Define Source Max Rows
Dim totalRows As Integer 'Define Total Rows
Dim destRange As String 'Define Destination Range
Dim sourceRange As String 'Define Source Range
lastRow = 1
Worksheets.Add().Name = "Sheet1"
For Each sourceSheet In Worksheets
If sourceSheet.Name <> "Sheet1" Then
sourceSheet.Activate
sourceMaxRows = sourceSheet.Cells(Rows.Count, "A").End(xlUp).Row
totalRows = lastRow + sourceMaxRows - 4
Let sourceRange = "A5:D" & sourceMaxRows
Range(sourceRange).Select
Selection.Copy
sourceSheet.Select
Set destSheet = Worksheets("Sheet1")
destSheet.Activate
Let destRange = "B" & lastRow & ":E" & totalRows
Range(destRange).Select
destSheet.Paste
destSheet.Select
lastRow = lastRow + sourceMaxRows - 4
End If
Next
Rows("1:1").Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Range("A1").Select
ActiveCell.FormulaR1C1 = "Product_Id"
Range("B1").Select
ActiveCell.FormulaR1C1 = "Category"
Range("C1").Select
ActiveCell.FormulaR1C1 = "Brand"
Range("D1").Select
ActiveCell.FormulaR1C1 = "Model"
Range("E1").Select
ActiveCell.FormulaR1C1 = "EAN"
Range("F1").Select
ActiveCell.FormulaR1C1 = "UPC"
Range("G1").Select
ActiveCell.FormulaR1C1 = "SKU"
Range("H1").Select
ActiveCell.FormulaR1C1 = "Supplier_Shop_Price"
Range("I1").Select
ActiveCell.FormulaR1C1 = "Invoice_Price"
Range("J1").Select
ActiveCell.FormulaR1C1 = "In_Stock"
Range("A1").Select
MsgBox "Updated"
End Sub
You need to build-up an algorithm on the following logic: for each sheet you run, the source column is "1" and the destination column is "2": at the end of each loop, you need to increment both variables by 2. Here is how your code algorithm should look like (I let you do the job of rearranging your specific code to the algorithm):
sourceColumnIndex = 1
destColumnIndex = 2
sourceColumn = Split(Cells(1, sourceColumnIndex).Address, "$")(1)
destColumn = Split(Cells(1, destColumnIndex).Address, "$")(1)
For Each sourceSheet In Worksheets
'do your job here: for example:
'...
sourceMaxRows = sourceSheet.Cells(Rows.Count, sourceColumn).End(xlUp).Row
'...
destRange = destColumn & lastRow & ":E" & totalRows
'...
'before to go to the next, readapt the indexes:
sourceColumnIndex = sourceColumnIndex + 2
destColumnIndex = destColumnIndex + 2
sourceColumn = Split(Cells(1, sourceColumnIndex).Address, "$")(1)
destColumn = Split(Cells(1, destColumnIndex).Address, "$")(1)
'we can go to the next with "C" and "D", then with "E" and "F" etc.
Next sourceSheet
NOTE 1
Such a function:
sourceColumn = Split(Cells(1, sourceColumnIndex).Address, "$")(1)
is just converting the column number to the associated letter by using the address and splitting it by "$".
NOTE 2
A passage like this is useless as well as slower:
Range("A1").Select
ActiveCell.FormulaR1C1 = "Product_Id"
Rather, try to re-factor your code like this:
Range("A1").FormulaR1C1 = "Product_Id"
without need of selecting the cell, but directly writing on its property (in this case I would rather use .Value, but you might want to use .FormulaR1C1, you know better than me.
AFTER THAT CHRISTMAS007 HAS CLEANED YOUR QUESTION
Well, clearly the key of all this is to use a variable letter. I might suggest you to embed the split into a function that converts numbers in letters:
Function myColumn(ByVal num As Integer) As String
myColumn = Split(Cells(1, num).Address, "$")(1)
End Function
and every time working with numbers. You can call the above function like this:
num = 1
Range(myColumn(num) & 1).Select
the above will select for you the range "A1", because you passed the number "1" into the function.
Of course, being your request a bit more detailed, this is something you should study yourself. But the idea is anyway that one: define the indexes at the beginning, such as indSource and indDest, then...
decrease them at your pleasure with indSource = indSource - 1 (or -2, or -3)
increase them at your pleasure with indDest = indDest + 1 (or +2, or +3)
and work within the loop to get your desired results.
I did it easier, by deleting the rows and added one new blank column in the macro and it's working as I want, I just added the code to the macro:
For Each sourceSheet In Worksheets
sourceSheet.Activate
Columns("F:I").Delete
Columns("H:J").Delete
Columns("I:N").Delete
Columns("E:E").Insert
Next
I have the following VBA code that takes a single row from Sheet "Tabled data", copies the data, then pastes the data into the next available row in Sheet "Running list". However the original row has formulas and I need the values to paste, not the formulas. I've seen numerous ways to do it with Range.PasteSpecial but this code didn't use Range and I'm not sure how to incorporate it.
Note: I modified this code from here: http://msdn.microsoft.com/en-us/library/office/ff837760(v=office.15).aspx. It originally had an IF statement to match content in a cell then paste it in a certain sheet according to the content in the cell. I only had one sheet to copy to and didn't need the IF. I don't really need to find the last row of data to copy either as it will only ever be one row with range of A2:N2. But if I take out the FinalRow section and the For and replace with Range("A2:N2") it doesn't work so I left those in.
Any guidance on how to add in the PasteValues property without making this more complicated? I'm also open to simplification of the For or FinalRow variable such as using Range. I'm only sort of familiar with VBA, having done a few things with it, but usually after much searching and modifying code.
Public Sub CopyData()
Sheets("Tabled data").Select
' Find the last row of data
FinalRow = Cells(Rows.Count, 1).End(xlUp).Row
' Loop through each row
For x = 2 To FinalRow
ThisValue = Cells(x, 1).Value
Cells(x, 1).Resize(1, 14).Copy
Sheets("Running list").Select
NextRow = Cells(Rows.Count, 1).End(xlUp).Row + 1
Cells(NextRow, 1).Select
ActiveSheet.Paste
Sheets("Tabled data").Select
Next x
End Sub
Hopefully we can actually make this more simple.
Public Sub CopyRows()
Sheets("Sheet1").UsedRange.Copy
lastrow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
'check if the last cell found is empty
If IsEmpty(ActiveSheet.Cells(lastrow, 1)) = True Then
'if it is empty, then we should fill it
nextrow = lastrow
Else
'if it is not empty, then we should not overwrite it
nextrow = lastrow + 1
End If
ActiveSheet.Cells(nextrow, 1).Select
ActiveSheet.Paste
End Sub
edit: I expanded it a little so that there won't be a blank line at the top
I found a working solution. I recorded a macro to get the paste special in there and added the extra code to find the next empty row:
Sub Save_Results()
' Save_Results Macro
Sheets("Summary").Select 'renamed sheets for clarification, this was 'Tabled data'
'copy the row
Range("Table1[Dataset Name]").Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy
' paste values into the next empty row
Sheets("Assessment Results").Select
Range("A2").Select
NextRow = Cells(Rows.Count, 1).End(xlUp).Row + 1
Cells(NextRow, 1).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
' Return to main sheet
Sheets("Data Assessment Tool").Select
End Sub
Just copy the data all at once, no need to do it a row at a time.
Sub CopyData()
With ThisWorkbook.Sheets("Tabled data")
Dim sourceRange As Range
Set sourceRange = .Range(.Cells(2, 1), .Cells(getLastRow(.Range("A1").Parent), 14))
End With
With ThisWorkbook.Sheets("Running list")
Dim pasteRow As Long
Dim pasteRange As Range
pasteRow = getLastRow(.Range("A1").Parent) + 1
Set pasteRange = .Range(.Cells(pasteRow, 1), .Cells(pasteRow + sourceRange.Rows.Count, 14))
End With
pasteRange.Value = sourceRange.Value
End Sub
Function getLastRow(ws As Worksheet, Optional colNum As Long = 1) As Long
getLastRow = ws.Cells(ws.Rows.Count, colNum).End(xlUp).Row
End Function
Private Sub Load_Click()
Call ImportInfo
End Sub
Sub ImportInfo()
Dim FileName As String
Dim WS1 As Worksheet
Dim WS2 As Worksheet
Dim ActiveListWB As Workbook
Dim check As Integer
'Application.ScreenUpdating = False
Set WS2 = ActiveWorkbook.Sheets("KE_RAW")
confirm = MsgBox("Select (.xlsx) Excel file for Data transfer." & vbNewLine & "Please ensure the sheets are named Sort List, Second and Third.", vbOKCancel)
If confirm = 1 Then
FileName = Application.GetOpenFilename(FileFilter:="Excel Files (*.xls*),*.xls*", _
Title:="Select Active List to Import", MultiSelect:=False)
If FileName = "False" Then
MsgBox "Import procedure was canceled"
Exit Sub
Else
Call CleanRaw
Set ActiveListWB = Workbooks.Open(FileName)
End If
Set WS1 = ActiveListWB.Sheets("Sort List")
WS1.UsedRange.Copy 'WS2.Range("A1")
' WS2.Range("A1").Select
WS2.UsedRange.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'WS2.Range ("A1")
ActiveWorkbook.Close False
'Call ClearFormulas
' Call RefreshAllPivotTables
Sheets("Key Entry Data").Select
'Sheets("Raw").Visible = False
'Application.ScreenUpdating = True
MsgBox "Data has been imported to workbook"
Else
MsgBox "Import procedure was canceled"
End If
Application.ScreenUpdating = True
End Sub
Sub CleanRaw()
Sheets("KE_RAW").Visible = True
Sheets("KE_RAW").Activate
ActiveSheet.Cells.Select
Selection.ClearContents
End Sub