I’m trying to make a button which on click will filter the database from a column of date for today’s date and copy the whole row of the following and paste them in a new sheet. I’m new to coding so please, help needed.
Private Sub CommandButton6_Click()
a = Worksheets("Follow Up").Cells(Rows.Count, 1).End(xlUp).Row
For i = 3 To a
If Worksheets("Follow Up").Cells(i, 15).Value = Date Then
Worksheets("Follow Up").Rows(i).Copy
Worksheets("today").Activate
Worksheets("today").Cells(2, 1).Select
ActiveSheet.Paste
End If
Next i
You could use an autofilter (note that the Sub will only look at today's date):
Private Sub CommandButton6_Click()
Dim wsFU As Worksheet
Dim wsTD As Worksheet
Set wsFU = Worksheets("Follow Up")
Set wsTD = Worksheets("today")
Application.DisplayAlerts = False
wsTD.Delete
Application.DisplayAlerts = True
a = wsFU.Cells(Rows.Count, 1).End(xlUp).Row
wsFU.AutoFilterMode = False
ActiveWorkbook.Sheets.Add(After:=ActiveWorkbook.Sheets(ActiveWorkbook.Sheets.Count)).Name = "today"
Set wsTD = Worksheets("today")
With wsFU.Range("A1:P" & a) 'adjust to end of data columns
.AutoFilter Field:=15, Criteria1:=Format(Date, "mm/dd/yy") ' adjust to what your date format looks like
.SpecialCells(xlCellTypeVisible).Copy Destination:=wsTD.Range("A2")
End With
wsFU.AutoFilterMode = False
End Sub
If Today Copy to Worksheet
The Code
Private Sub CommandButton6_Click()
Dim rngU As Range ' Union Range
Dim a As Long ' Source Last Row
Dim b As Long ' Target Last Row
Dim i As Long ' Source Row Counter
' Source Worksheet
With Worksheets("Follow Up")
a = .Cells(.Rows.Count, 1).End(xlUp).Row
For i = 3 To a
If .Cells(i, 15).Value = Date Then
If Not rngU Is Nothing Then
Set rngU = Union(rngU, .Cells(i, 1))
Else
Set rngU = .Cells(i, 1)
End If
End If
Next
End With
' Target Worksheet
If Not rngU Is Nothing Then
With Worksheets("today")
b = .Cells(.Rows.Count, 1).End(xlUp).Row
rngU.EntireRow.Copy .Rows(b + 1)
Set rngU = Nothing
End With
End If
End Sub
Related
So I have designed this code to insert new entries into my master Database Log but when I run the code it is much too slow.
Private Sub CommandButton2_Click()
Dim ws As Worksheet
Dim LR As Long, i As Long, iRow As Long
Set ws = ThisWorkbook.Worksheets("Data Entry")
With ws
LR = .Cells(Rows.Count, 1).End(xlUp).Row
If 2 > LR Then Exit Sub
iRow = 3
For i = 1 To LR
If .Cells(i, 1).DisplayFormat.Interior.Color = RGB(217, 230, 251) Then
Worksheets("Call Log").Rows("3:3").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
.Cells(i, 1).Resize(1, 7).Copy ThisWorkbook.Worksheets("Call Log").Cells(iRow, "A")
End If
Next i
End With
Set ws = Nothing
End Sub
As you can see, my code goes through the range, determines if it matches my criteria (in this case the color of the cell) and then Inserts a row in the destination Worksheet and copies the data into that newly created row over and over until it finishes. I've thought of maybe having it select all of the necessary cells, copy and then insert them all at once into the destination worksheet, but I'm not sure how to go about that.
Any help is greatly appreciated!
One of the things you are doing obsoletely, is copying something to the clipboard, while this is not necessary: instead of
Range("<somewhere>").Copy
Range("<elsewhere>").Paste
You might simply do:
Range("<elsewhere>".Value = Range("<somewhere>").Value
It's always a good idea to turn off screen updating and set calculations to manual (unless you need it)
Application.SceenUpdating = false
Application.calculations = xlmanual
Then set them back to true and xlautomatic at the end of the code.
Not sure if the syntaxes is correct, I'm typing from my phone
If you absolutely need to copy the source formatting of the cells also, then you could use a filter and then copy only the visible cells, all in one go. Something like this:
Private Sub CommandButton2_Click()
Const shtDataName As String = "Data Entry"
Const shtLogName As String = "Call Log"
Dim shtData As Worksheet
Dim shtLog As Worksheet
'
'Make sure required resources are available
Set shtData = GetWorksheet(shtDataName, ThisWorkbook)
If shtData Is Nothing Then
MsgBox "Missing sheet <" & shtDataName & ">!", vbInformation, "Cancelled"
Exit Sub
End If
Set shtLog = GetWorksheet(shtLogName, ThisWorkbook)
If shtLog Is Nothing Then
MsgBox "Missing sheet <" & shtLogName & ">!", vbInformation, "Cancelled"
Exit Sub
End If
'
'Check last row
Dim lastRow As Long
'
lastRow = shtData.Cells(Rows.Count, 1).End(xlUp).Row
If lastRow = 1 Then Exit Sub
'
Dim filterColor As Long
'
'Filter Range
filterColor = RGB(217, 230, 251)
With Range(shtData.Cells(1, 1), shtData.Cells(lastRow, 1))
.AutoFilter Field:=1, Criteria1:=filterColor, Operator:=xlFilterCellColor
End With
'
Dim rng As Range
Const lastCol As Long = 7
Dim firstRow As Long
'
'Get filtered range
'First row remains visible regardless of filter. Check it
If shtData.Cells(1, 1).Cells(1, 1).DisplayFormat.Interior.Color <> filterColor Then
firstRow = 2
Else
firstRow = 1
End If
On Error Resume Next
Set rng = Range(shtData.Cells(firstRow, 1), shtData.Cells(lastRow, lastCol)).SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If rng Is Nothing Then Exit Sub 'Nothing meets criteria
'
Dim tempArea As Range
Dim rCount As Long
'
'Get required rows count
For Each tempArea In rng.Areas
rCount = rCount + tempArea.Rows.Count
Next tempArea
'
'Insert rows
Const iRow As Long = 3
'
shtLog.Rows(iRow & ":" & iRow + rCount - 1).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
rng.Copy shtLog.Cells(iRow, 1)
'
'Remove filter
rng.AutoFilter
End Sub
But, if you don't care about source formatting then you could use something like this:
Private Sub CommandButton2_Click()
Const shtDataName As String = "Data Entry"
Const shtLogName As String = "Call Log"
Dim shtData As Worksheet
Dim shtLog As Worksheet
'
'Make sure required resources are available
Set shtData = GetWorksheet(shtDataName, ThisWorkbook)
If shtData Is Nothing Then
MsgBox "Missing sheet <" & shtDataName & ">!", vbInformation, "Cancelled"
Exit Sub
End If
Set shtLog = GetWorksheet(shtLogName, ThisWorkbook)
If shtLog Is Nothing Then
MsgBox "Missing sheet <" & shtLogName & ">!", vbInformation, "Cancelled"
Exit Sub
End If
'
'Check last row
Dim lastRow As Long
'
lastRow = shtData.Cells(Rows.Count, 1).End(xlUp).Row
If lastRow = 1 Then Exit Sub
'
'Read data in array (super fast)
Dim rng As Range
Dim arrData() As Variant
Const lastCol As Long = 7
'
Set rng = Range(shtData.Cells(1, 1), shtData.Cells(lastRow, lastCol))
arrData = rng.Value2
'
'Store relevant row numbers
Dim collRows As New Collection
Dim i As Long
Dim filterColor As Long: filterColor = RGB(217, 230, 251)
'
For i = LBound(arrData) To UBound(arrData)
If rng.Cells(i, 1).DisplayFormat.Interior.Color = filterColor Then
collRows.Add i
End If
'
'I am not a fan of using colors for filtering. It's much faster to have a separate
' column (indicator column) that can be used for that. This way we could do
' something like: If arrData(i, indCol) = expectedValue Then ...
' which is much faster than accesing cells
Next i
'
'Prepare data for writing
Dim arrFiltered() As Variant
ReDim arrFiltered(1 To collRows.Count, 1 To lastCol)
Dim r As Variant
Dim c As Long
'
i = 0
For Each r In collRows
i = i + 1
For c = 1 To lastCol
arrFiltered(i, c) = arrData(r, c)
Next c
Next r
'
'Insert rows
Const iRow As Long = 3
'
shtLog.Rows(iRow & ":" & iRow + collRows.Count - 1).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
'
'Write
With Range(shtLog.Cells(iRow, 1), shtLog.Cells(iRow + collRows.Count - 1, lastCol))
.Value2 = arrFiltered
End With
End Sub
Private Function GetWorksheet(ByVal sheetName As String, ByVal book As Workbook) As Worksheet
On Error Resume Next
Set GetWorksheet = book.Worksheets(sheetName)
On Error GoTo 0
End Function
The above is rushed code but proves some ways of doing the task. Other things that need to be considered are:
Are the worksheets protected? if yes, filtering and inserting rows can be an issue
Inserting rows will fail if the rows are intersecting multiple dynamic tables (listobjects)
Code needs to be changed if data doesn't start on row 1 in the source
and probably others that don't come to mind right now
Related to Excel VBA - I have a large dataset and would like to split it by Ratings. For a small dataset the code works perfectly, but for a large dataset (11,000 rows & 20 columns), it loops and either get "Restart Excel program" or a 438 error. Need some help to optimize/correct the code. Using Excel 2013
I tried Cut/paste instead of copy/paste - it does not work
Private Sub SplitData_Click()
a = Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To a
If Sheets("Sheet1").Cells(i, 2).Value = "AAA" Then
Sheets("Sheet1").Rows(i).Cut
Sheets("Sheet2").Activate
b = Sheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Row
Sheets("Sheet2").Cells(b + 1, 1).Select
ActiveSheet.Paste
End If
If Sheets("Sheet1").Cells(i, 2).Value = "BBB" Then
Sheets("Sheet1").Rows(i).Cut
Sheets("Sheet3").Activate
c = Sheets("Sheet3").Cells(Rows.Count, 1).End(xlUp).Row
Sheets("Sheet3").Cells(c + 1, 1).Select
ActiveSheet.Paste
End If
If Sheets("Sheet1").Cells(i, 2).Value = "CCC" Then
Sheets("Sheet1").Rows(i).Cut
Sheets("Sheet4").Activate
d = Sheets("Sheet4").Cells(Rows.Count, 1).End(xlUp).Row
Sheets("Sheet4").Cells(d + 1, 1).Select
ActiveSheet.Paste
End If
Sheets("Sheet1").Activate
Next
Application.CutCopyMode = False
End Sub
I want to split the large data set into different groups (Sheets) based on the value - AAA, BBB or CCC. I have 10 such value flags.
Another approach:
Private Sub SplitData_Click()
Dim a As Long, i As Long, sht As Worksheet, sDest As String
Set sht = Sheets("Sheet1")
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
a = sht.Cells(sht.Rows.Count, 1).End(xlUp).Row
For i = a To 2 Step -1 'work from bottom up
sDest = ""
'need to cut this row?
Select Case sht.Cells(i, 2).Value
Case "AAA": sDest = "Sheet2"
Case "BBB": sDest = "Sheet3"
Case "CCC": sDest = "Sheet4"
End Select
'cut row to relevant sheet
If Len(sDest) > 0 Then
sht.Rows(i).Cut Sheets(sDest).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
End If
Next i
Application.CutCopyMode = False
Application.Calculation = xlCalculationAutomatic
End Sub
NOTE: locating the "cut to" cell using xlUp relies on every previous row in the destination sheet having a value in ColA - if any are empty then rows could get overwritten by the next pasted row.
Try this. This should be faster as this doesn't involve ANY looping.
Logic
Use Autofilter to Copy the rows across in one go
Clear rows after copying
Delete blank rows in one go using Autofilter
Code
Dim wsInput As Worksheet
Sub SplitData_Click()
Dim wsOutputA As Worksheet
Dim wsOutputB As Worksheet
Dim wsOutputC As Worksheet
Set wsInput = ThisWorkbook.Sheets("Sheet1")
Set wsOutputA = ThisWorkbook.Sheets("Sheet2")
Set wsOutputB = ThisWorkbook.Sheets("Sheet3")
Set wsOutputC = ThisWorkbook.Sheets("Sheet4")
Dim lrow As Long
Dim rng As Range
With wsInput
.AutoFilterMode = False
lrow = .Range("A" & .Rows.Count).End(xlUp).Row
Set rng = .Range("A1:A" & lrow)
'~~> Filter on AAA
HandleIt "AAA", rng, wsOutputA
'~~> Filter on BBB
HandleIt "BBB", rng, wsOutputB
'~~> Filter on CCC
HandleIt "CCC", rng, wsOutputC
'~~> Filter on blanks
With rng
.AutoFilter Field:=1, Criteria1:="="
.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
End With
.AutoFilterMode = False
End With
End Sub
Private Sub HandleIt(AFCrit As String, r As Range, wks As Worksheet)
Dim OutputRow As Long
Dim filteredRange As Range
With r
.AutoFilter Field:=1, Criteria1:=AFCrit
Set filteredRange = .Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow
End With
If Not filteredRange Is Nothing Then
With wks
OutputRow = .Range("A" & .Rows.Count).End(xlUp).Row + 1
filteredRange.Copy .Rows(OutputRow)
filteredRange.ClearContents
End With
End If
wsInput.ShowAllData
End Sub
In Action
Note: The above code took 4 seconds on 21k rows x 31 columns data
Please see How to avoid using Select in Excel VBA.
Option Explicit
Private Sub SplitData_Click()
Dim i As Long
With Worksheets("Sheet1")
For i = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row
Select Case .Cells(i, 2).Value
Case "AAA"
MoveToEndOf .Rows(i), Worksheets("Sheet2")
Case "BBB"
MoveToEndOf .Rows(i), Worksheets("Sheet3")
Case "CCC"
MoveToEndOf .Rows(i), Worksheets("Sheet4")
End Select
Next
End With
End Sub
Private Sub MoveToEndOf(ByVal what As Range, ByVal where As Worksheet)
what.Cut where.Cells(where.Rows.Count, 1).End(xlUp).Offset(1, 0)
End Sub
Here is an option without using copy/paste
Private Sub SplitData_Click()
Dim a As Long
Dim b As Long
Dim c As Long
Dim d As Long
Dim i As Long
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim ws3 As Worksheet
Dim ws4 As Worksheet
Set ws1 = ThisWorkbook.Sheets("Sheet1")
Set ws2 = ThisWorkbook.Sheets("Sheet2")
Set ws3 = ThisWorkbook.Sheets("Sheet3")
Set ws4 = ThisWorkbook.Sheets("Sheet4")
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
a = ws1.Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To a
If ws1.Cells(i, 2).Value = "AAA" Then
b = ws2.Cells(Rows.Count, 1).End(xlUp).Row + 1
ws2.Rows(b).Value = ws1.Rows(i).Value
End If
If ws1.Cells(i, 2).Value = "BBB" Then
c = Sheets("Sheet3").Cells(Rows.Count, 1).End(xlUp).Row + 1
ws2.Rows(c).Value = ws1.Rows(i).Value
End If
If ws1.Cells(i, 2).Value = "CCC" Then
d = Sheets("Sheet4").Cells(Rows.Count, 1).End(xlUp).Row + 1
ws2.Rows(d).Value = ws1.Rows(i).Value
End If
Next i
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With
End Sub
I'm using a button macro to copy a range, it's super simple:
Worksheets("SNOW").Range("C6:D18").Copy
Now, how would I modify this to say "Copy this range, but if the value in column D is blank, skip that row completely in the copy process"? Dealing with text, not numbers.
Thanks.
You'll have to use Union to create a range that contains only your select rows (if the value in column D is not blank):
Sub Test()
Dim rng As Range, i As Long
For i = 6 To 18
If Range("D" & i).Value <> "" Then
If rng Is Nothing Then
Set rng = Range("C" & i & ":D" & i)
Else
Set rng = Application.Union(rng, Range("C" & i & ":D" & i))
End If
End If
Next i
If Not rng Is Nothing Then
rng.Copy
End If
End Sub
You could filter and copy the filtered data:
Sub Copy_Filtered()
With ThisWorkbook.Worksheets("Snow")
If .FilterMode Then
.ShowAllData
End If
With .Range("A6:D18")
.AutoFilter Field:=4, Criteria1:="<>"
.Copy 'Destination:=ThisWorkbook.Worksheets("Blizzard").Range("A1")
End With
End With
End Sub
NB: Uncomment the Destination to paste the range to the Blizzard sheet.
You can copy each area separately.
Option Explicit
Sub foo()
Dim ws As Worksheet, r As Range, rCpy As Range
Dim rDest As Range
Set ws = Worksheets("SNOW")
With ws
Set r = .Range(.Cells(6, 4), .Cells(18, 4)).SpecialCells(xlCellTypeConstants)
Set rDest = .Cells(6, 10)
For Each rCpy In r.Areas
Set rCpy = rCpy.Offset(columnoffset:=-1).Resize(columnsize:=2)
rCpy.Copy rDest
Set rDest = rDest.Offset(rCpy.Rows.Count)
Next rCpy
End With
End Sub
Another method, which will work no matter what the contents of the source data:
Set ws = Worksheets("SNOW")
With ws
.Rows.Hidden = False
Set rDest = .Cells(1, 6)
Set r = .Range(.Cells(6, 4), .Cells(18, 4)).SpecialCells(xlCellTypeBlanks)
r.EntireRow.Hidden = True
Set r = .Range(.Cells(6, 3), .Cells(18, 4)).SpecialCells(xlCellTypeVisible)
.Rows.Hidden = False
r.Copy rDest
End With
I have few sheet that i would like to read all comments from each sheet.
I managed to get the comments but what i could get is the first cell of the same row and column of the commented cell.( attached photo)
red - commented cell.
green - required cell value.
Sub ShowCommentsAllSheets()
'Update 20140508
Dim commrange As Range
Dim rng As Range
Dim ws As Worksheet
Dim newWs As Worksheet
Set newWs = Application.Worksheets("CRs")
newWs.Range("A1").Resize(1, 4).Value = Array("Sheet", "A", "Value", "Comment")
Application.ScreenUpdating = False
On Error Resume Next
For Each ws In Application.ActiveWorkbook.Worksheets
Set commrange = ws.Cells.SpecialCells(xlCellTypeComments)
If Not commrange Is Nothing Then
i = newWs.Cells(Rows.Count, 1).End(xlUp).Row
For Each rng In commrange
i = i + 1
newWs.Cells(i, 1).Resize(1, 4).Value = Array(ws.Name, rng.Address, rng.Value, rng.Comment.Text)
Next
End If
Set commrange = Nothing
Next
newWs.Cells.WrapText = False
Application.ScreenUpdating = True
End Sub
Perhaps just change this line?
newWs.Cells(i, 1).Resize(1, 5).Value = Array(ws.Name, rng.Address, rng.Value, rng.Comment.Text, ws.Cells(rng.Row, 2))
I am new to VBA.
For each cell in columns("c:c")
If cell.value = "TRUE" Then
'vba is required for selecting corresponding cells in columns A and B
Next cell
Else:
exit sub
End if
end sub
please make suitable corrections
Try this one:
Sub test()
Dim lastrow As Long
Dim c As Range, rng As Range
'change Sheet1 to suit
With ThisWorkbook.Worksheets("Sheet1")
lastrow = .Cells(.Rows.Count, "C").End(xlUp).Row
For Each c In .Range("C1:C" & lastrow)
If UCase(c.Text) = "FALSE" Then
If rng Is Nothing Then
Set rng = .Range("A" & c.Row).Resize(, 2)
Else
Set rng = Union(rng, .Range("A" & c.Row).Resize(, 2))
End If
End If
Next c
End With
If Not rng Is Nothing Then rng.Select
End Sub