I had a coding suggested by others, but i no fully match my requirements. What i need are "INSERT" those data to another worksheet rather than "PASTE" them, because when using "PASTE" previous data will be overwrite.
Below are the coding, any can help to change the "PASTE" to "INSERT"? I had try many times also error.
Private Sub All_Click()
With Worksheets("Sheet1")
'turn off AutoFilter if it is on
If .AutoFilterMode Then .AutoFilterMode = False
'set a CF rule for <Now
With .Range(.Cells(2, "L"), .Cells(Rows.Count, "L").End(xlUp))
.FormatConditions.Delete
With .FormatConditions.Add(Type:=xlExpression,Formula1:="=$L2<NOW()")
.Font.Color = vbRed
End With
End With
'add an AutoFilter for red font cells
With .Range(.Cells(1, "L"), .Cells(Rows.Count, "L").End(xlUp))
.AutoFilter Field:=1, Criteria1:=vbRed, _
Operator:=xlFilterFontColor
End With
'deal with the red font cells
With .Range(.Cells(2, "L"), .Cells(Rows.Count, "L").End(xlUp))
If CBool(Application.Subtotal(103, .Cells)) Then
With .SpecialCells(xlCellTypeVisible)
'select them (there are better ways to get things done)
'.Select
'copy them to sheet2 (do not need Select for this)
.EntireRow.Copy Destination:=Sheet2.Range("A4").Rows("1:1")
'delete them
.EntireRow.Delete
End With
End If
End With
'turn off AutoFilter
If .AutoFilterMode Then .AutoFilterMode = False
End With
End Sub
If you want to paste them after existing data on your Sheet2, you need to find the last row on that sheet and set your destination as that row + 1.
Related
Having tried for many hours without a solution, I am asking for help to please clear the contents of Columns A through H from first row where Col G = - to row 50000. I have tried many approaches without success. Users currently have instructions to do this manually, but I sure wish it could be automated by adding it to the code below. Deleting the rows is no good because it upsets array formulas elsewhere that use this data.
Sub CopyPasteToPrYrData()
'
' CopyPasteToPrYrData Macro
'
' Keyboard Shortcut: Ctrl+Shift+C
'
Sheets("Barrel List by Producer").Range("AD3:AK30000").Copy
Sheets("Prior Years Data").Range("A1:H29998").PasteSpecial Paste:=xlPasteValuesAndNumberFormats
Sheet1.Activate
Range("A1:B29998").Select
With Selection
Selection.NumberFormat = "General"
.Value = .Value
End With
Range("A1:H29998").Sort Key1:=Range("G1"), Order1:=xlDescending, Header:=xlNo
End Sub
I tried creating a concatenated range formula in Excel from calculated Find values, code to copy the first row with only a space in it and copying that down, building a range formula in VBA instead of Excel, and various iterations of those until I gave up on my ability to solve the problem.
you can use AutoFilter() to filter negative values and clear them
here's a possible code, where I also refactored your existing one to add more consistency
Sheets("Barrel List by Producer").Range("AD3:AK17").Copy
With Sheets("Prior Years Data")
.Range("A1").PasteSpecial Paste:=xlPasteValuesAndNumberFormats
With .Range("A1").CurrentRegion
.NumberFormat = "General"
.Value = .Value
.Sort Key1:=.Range("G1"), Order1:=xlDescending, Header:=xlNo
.AutoFilter field:=7, Criteria1:="<0"
With .Resize(.Rows.Count - 1).Offset(1)
If CBool(Application.Subtotal(103, .Columns(1))) Then
.SpecialCells(xlCellTypeVisible).ClearContents
End If
End With
End With
.AutoFilterMode = False
End With
Sub CopyPasteToPrYrData()
'
' CopyPasteToPrYrData Macro
'
' Keyboard Shortcut: Ctrl+Shift+C
'
Sheets("Barrel List by Producer").Range("AD3:AK30000").Copy
Sheets("Prior Years Data").Range("A1:H29998").PasteSpecial Paste:=xlPasteValuesAndNumberFormats
Sheet1.Activate
Range("A1:B29998").Select
With Selection
Selection.NumberFormat = "General"
.Value = .Value
End With
Range("A1:H29998").Sort Key1:=Range("G1"), Order1:=xlDescending, Header:=xlNo
Columns("G:G").Select
Selection.Find(What:="-", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False).Activate
ActiveCell.EntireRow.Select
Range(Selection, Selection.End(xlDown)).Select
Selection.ClearContents
End Sub
I have a macro I've made, but when I run the macro it fills down the updated value to the bottom of the sheet instead of to the bottom of the data set, is there a way to make it only fill down partially?
With ActiveSheet
.AutoFilterMode = False
With Range("I1", Range("I" & Rows.Count).End(xlDown))
.AutoFilter Field:=1, Criteria1:="="
On Error Resume Next
.Resize(.Rows.Count - 1).Offset(1, 0).SpecialCells(xlCellTypeVisible).Value = "1"
On Error GoTo 0
End With
.AutoFilterMode = False
End With
Thank you in advance and sorry for the bad english!
I want
fix100-->current column & last row nummber?
Cells(100, ActiveCell.Column))--->Cells(???, ActiveCell.Column))
Sub ExcelVBA_CurrentValuecu_Filter()
ActiveSheet.Range(Cells(1, ActiveCell.Column), Cells(100, ActiveCell.Column)).AutoFilter Field:=1, Criteria1:=ActiveCell.Value
End Sub
Try this code:
Sub ExcelVBA_CurrentValuecu_Filter()
With ThisWorkbook.ActiveSheet
.Range(.Cells(1, ActiveCell.Column), .Cells(.Rows.Count, ActiveCell.Column).End(xlUp)). _
AutoFilter Field:=1, Criteria1:=ActiveCell.Value
End With
End Sub
The statement .Cells(.Rows.Count, ActiveCell.Column).End(xlUp) will find the last cell in your column that has data in it. I used a With block to properly qualify all the ranges you're using in your code. That's why there's a dot . in front of .Cells. This is the same as always writing ActiveSheet.Cells.
So I am writing a code that after I have filtered on certain criteria I want to select the data (excluding the headers) and if the selection is not empty copy and paste in into a different sheet. If the selection is empty, do nothing. My problem is that it seems my code always thinks that the selection is not empty even when it is so it always copies the data.
Sub paste_filter()
Sheets("RawData").Select
Dim rng As Range
With ActiveSheet.AutoFilter.Range.Offset(1, 0).Resize(Rows.Count - 1).Select
Set rng = Selection
If Application.WorksheetFunction.CountA(rng) > 0 Then
rng.Copy
Sheets("Report").Select
Range("A5").Select
Selection.End(xlDown).Select
ActiveCell.Offset(1, 0).Range("A1").Select
ActiveSheet.Paste
End If
End With
End Sub
I want to copy data in certain cells to another sheet in a table.
My code copies the data and searches for the cell to be pasted to. If there is a value in the destination cell, it is looped to check the subsequent rows in the same column until it finds an empty cell.
If there's 2000 rows of data currently in the table, it will search all 2000 cells before landing in the 2001st row.
The amount of time taken to execute the code is affected by the size of the table.
Is there any way to execute faster?
Below is a sample, its copying data from two cells.
Sub Test()
Sheets("Sheet1").Select
Range("K10").Select
Selection.Copy
Sheets("Table").Select
Range("A2").Select
Do While Not (ActiveCell.Value = "")
ActiveCell.Offset(1, 0).Activate
Loop
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Sheets("Sheet1").Select
Range("G15").Select
Selection.Copy
Sheets("Table").Select
Range("B2").Select
Do While Not (ActiveCell.Value = "")
ActiveCell.Offset(1, 0).Activate
Loop
End sub
Try following sub.
Sub CopyPaste()
Dim sht1, sht2 As Worksheet
Set sht1 = Worksheets("Sheet1")
Set sht2 = Worksheets("Table")
sht1.Range("K10").Copy sht2.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
sht1.Range("G15").Copy sht2.Cells(Rows.Count, 2).End(xlUp).Offset(1, 0)
End Sub
It's unclear on whether you expect to find interim blank cells within the worksheet's used range or whether you expect to always put the new values at the bottom of the used range. This should work for both scenarios.
Sub Test()
Dim ws1 As Worksheet
Set ws1 = Worksheets("sheet1")
With Worksheets("table")
'force a definition for a .UsedRange on the worksheet
.Cells(.Rows.Count, "A") = Chr(32)
.Columns(1).SpecialCells(xlCellTypeBlanks).Cells(1) = ws1.Cells(10, "K").Value
.Columns(1).SpecialCells(xlCellTypeBlanks).Cells(1) = ws1.Cells(15, "G").Value
'clear the artificial .UsedRange
.Cells(.Rows.Count, "A").Clear
'Debug.Print .UsedRange.Address(0, 0)
End With
End Sub