I want to copy data from sheet 2 to sheet 5 with multiple criteria.
example data:
I wrote the following code ...
Dim myrange As Range
Set myrange = Worksheets("Sheet2").Range("a1:k50")
myrange.Parent.AutoFilterMode = False
myrange.AutoFilter field:=1, criteria1:="=Monitors"
myrange.AutoFilter field:=2, criteria1:="=Jul-19"
myrange.AutoFilter field:=3, criteria1:="=1"
myrange.AutoFilter field:=5, criteria1:="=P"
myrange.Parent.AutoFilter.Range.Copy
With Sheet5.Range("a10")
.PasteSpecial Paste:=8
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
.Select
End With
myrange.Parent.AutoFilterMode = False
When I run the code it copies headings only.
the output should be.
Any thoughts?
I'd do in a slightly different way, as I'm not too into using filters in macros.
Please note this code will paste in Sheet5 last row. Feel free to adapt it to your needs.
Also, please note using dates (like "Jul-19") in this format could cause you some issues. Try to convert it (on the code below) to a value depending on your original table's format:
Sub testStackOverflow()
Dim myrange As Range
Dim Criteria1 As String
Dim Criteria2 As String
Dim Criteria3 As String
Dim Criteria4 As String
Set myrange = Worksheets("Sheet2").Range("A1:A50")
Criteria1 = "Monitors"
Criteria2 = "Jul-19"
Criteria3 = "1"
Criteria4 = "P"
For Each SearchCell In myrange
Debug.Print SearchCell.Value
If SearchCell.Value = Criteria1 Then
If SearchCell.Offset(0, 1).Value = Criteria2 Then
If SearchCell.Offset(0, 2).Value = Criteria3 Then
If SearchCell.Offset(0, 4).Value = Criteria4 Then
LastRow = Sheets("Sheet5").Range("A1048576").End(xlUp).Row + 1
Sheets("Sheet5").Range("A" & LastRow).Value = SearchCell.Value
Sheets("Sheet5").Range("B" & LastRow).Value = SearchCell.Offset(0, 1).Value
Sheets("Sheet5").Range("C" & LastRow).Value = SearchCell.Offset(0, 2).Value
Sheets("Sheet5").Range("D" & LastRow).Value = SearchCell.Offset(0, 3).Value
Sheets("Sheet5").Range("E" & LastRow).Value = SearchCell.Offset(0, 4).Value
End If
End If
End If
End If
Next SearchCell
End Sub
Related
I am new to vba and need a little help. I want to copy copy column A & C to sheet 2 but my concatenation syntax (my_range = rng1&":"&rng2) won't work.
I have tried other syntax too but it's just syntax to concatenate Strings into a single column and that's what I am looking for. What I want is Column A & C from sheet 1 to be copied in Column A & B in sheet 2.
Sub CommandButton1_Click()
Dim my_range As String, rng1 As String, rng2 As String
search_value = Sheets(2).Cells(i, 1).Value = 1
Sheets(1).Activate
For i = 2 To 100
If Sheets(1).Cells(i, 1).Value = search_value Then
rng1 = "A" & i
rng2 = "C" & i
my_range = rng1&":"&rng2
Sheets(1).Rande(my_range).Select
Selection.Copy
Sheets(2).Activate
Sheets(2).Range("A2").Select
Selection.PasteSpecial: xlPasteAll , SkipBlanks:=True, Transpose:=False
End If
Next
Application.CutCopyMode = False
Sheets(2).Cells(1, 2).Select
End Sub
The simplest way to create a range from one cell to the other is the following:
my_range = Range(rng1, rng2)
(I found some examples on this website.)
Do it like below :
rng1 = "A" & CStr(i)
rng2 = "C" & CStr(i)
my_range = rng1 & ":" & rng2
I have table like this
and i want to filter base on this criteria
VAlue = between 2000 and 3000
Status = 'FALSE'
become like this, the filter on Column F & G
and this is my code
Dim LastRow As Long
Dim i, Hide, popup As Long
Dim message As String
Dim LRow As Long
Dim sht As Worksheet
ActiveSheet.AutoFilterMode = False
Columns.EntireColumn.Hidden = False
Rows.EntireRow.Hidden = False
Columns("O:R").EntireColumn.Delete
Range("O:R").EntireColumn.Insert
Range("F1").Value = "PO sTATUS"
Range("G1").Value = "Value"
Set sht = ActiveSheet
LastRow = sht.Range("B" & Rows.Count).End(xlUp).Row
With sht.Range("F1:F" & LastRow)
.Formula = "=B1"
.Value = .Value
.AutoFilter field:=1, Criteria1:="FALSE"
End With
With sht.Range("G1:G" & LastRow)
.Formula = "=D1"
.Value = .Value
.AutoFilter field:=1, Criteria1:=">=2000", Operator:=xlAnd, Criteria2:="<=3000"
End With
and this code always show only Row 1 no values
Try applying the filter all at once?
Dim LastRow As Long
Dim i, Hide, popup As Long
Dim message As String
Dim LRow As Long
Dim sht As Worksheet
ActiveSheet.AutoFilterMode = False
Columns.EntireColumn.Hidden = False
Rows.EntireRow.Hidden = False
Columns("O:R").EntireColumn.Delete
Range("O:R").EntireColumn.Insert
Range("F1").Value = "PO sTATUS"
Range("G1").Value = "Value"
Set sht = ActiveSheet
LastRow = sht.Range("B" & Rows.Count).End(xlUp).Row
With sht.Range("F1:F" & LastRow)
.Formula = "=B1"
.Value = .Value
End With
With sht.Range("G1:G" & LastRow)
.Formula = "=D1"
.Value = .Value
End With
With sht.Range("F1:G" & LastRow)
.AutoFilter
.AutoFilter field:=1, Criteria1:="FALSE"
.AutoFilter field:=2, Criteria1:=">=2000", Operator:=xlAnd, Criteria2:="<=3000"
End With
I have to generate a spreadsheet of upcoming events, and I use a macro that creates a thick line that separates each date from the one above it. It's based on the value change in the "Date" column". However, sometimes I have to filter the data by another criteria (say, the county). In those cases, the offset macro I've been using doesn't always work, as the data that changes and produces the line is in a hidden row, and therefore the line is as well. Can anyone help?
I've tried various ways of defining the range as active cells only, but I don't think I'm doing it correctly.
The macro I'm using is as follows, without applying to hidden rows:
Sub UpcomingLines()
Application.ScreenUpdating = False
Dim LastRow As Long
LastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Dim rng As Range
For Each rng In Range("A1:A100" & LastRow)
If rng <> rng.Offset(1, 0) Then
Range("A" & rng.Row & ":H" & rng.Row).Borders(xlEdgeBottom).Weight = xlThick
End If
Next rng
Application.ScreenUpdating = True
End Sub
I've tried integrating SpecialCells like this:
Sub UpcomingLines()
Application.ScreenUpdating = False
Dim LastRow As Long
LastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Dim rng As Range
Set myrange = Range("A1:H" & Cells(Rows.Count, "A").End(xlUp).Row).SpecialCells(xlCellTypeVisible)
For Each rng In Range("A1:A100" & LastRow)
If rng <> rng.Offset(1, 0) Then
Range("A" & myrange.Row & ":H" & rng.Row).Borders(xlEdgeBottom).Weight = xlThick
End If
Next rng
Application.ScreenUpdating = True
End Sub
However, this generates lines in places I don't want them -- basically, the show up between date changes, but also everyplace there is a hidden row, even if there is no date change before or after the hidden row.
Try something like this:
Sub UpcomingLines()
Dim ws As Worksheet, LastRow As Long, c As Range, theDate
Application.ScreenUpdating = False
Set ws = ActiveSheet
ws.Range("A1").CurrentRegion.Borders.LineStyle = xlNone 'remove existing borders
LastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
theDate = 0
For Each c In ws.Range("A2:A" & LastRow).SpecialCells(xlCellTypeVisible)
'different date from previous visible row?
If c.Value <> theDate Then
'add border to top of row if not the first change
If theDate <> 0 Then c.Resize(1, 8).Borders(xlEdgeTop).Weight = xlThick
theDate = c.Value 'remember this date
End If
Next c
Application.ScreenUpdating = True
End Sub
I have the VBA code setup to delete rows, format columns, add a heading, etc. Now I need this code to be repeated on each Sheet in the Workbook. Some Workbooks will have 1 sheet, some could have dozens. I've looked at various answers, but can't find something that works.
Here is a snippet of the code I need to have repeated on each sheet:
Sub C_FormattingWTitle_Step3_do_on_each_tab()
'Delete all blank empty rows
Dim FirstBlankCell As Long, rngFound As Range
With ActiveSheet
Set rngFound = .Columns("G:G").Find("*", After:=.Range("G1"), searchdirection:=xlPrevious, LookIn:=xlValues)
If Not rngFound Is Nothing Then FirstBlankCell = rngFound.Row
End With
If ActiveCell.SpecialCells(xlLastCell) <> rngFound Then
Selection.SpecialCells(xlCellTypeBlanks).Select
ActiveWindow.SmallScroll Down:=9
Selection.EntireRow.Delete
Else
Range("A1").Select
End If
'Remove all not 260563 or header in SiteID column
Dim LR As Long, i As Long
LR = Range("G" & Rows.Count).End(xlUp).Row
For i = LR To 2 Step -1
If Not (Range("G" & i).Value Like "260563") And Not (Range("G" & i).Value Like "SiteID") Then Rows(i).Delete
Next i
'Remove all False values and header in Sign in Success column
Dim FR As Long, p As Long
FR = Range("F" & Rows.Count).End(xlUp).Row
For p = FR To 2 Step -1
If Not (Range("F" & p).Value Like True) And Not (Range("F" & p).Value Like "SignInSuccess") Then Rows(p).Delete
Next p
'Remove shading and formatting from header row
Rows("1:1").Select
With Selection.Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
'Format date/time
Columns("A:A").Select
Selection.NumberFormat = "m/d/yyyy hh:mm:ss;#"
After the code is run on every sheet, I want to insert Save As code. Any help would be greatly appreciated.
Use a separate sub to call and execute that subroutine:
Dim wkst As Worksheet
For Each wkst In ActiveWorkbook.Worksheets
Call C_FormattingWTitle_Step3_do_on_each_tab(wkst)
Next
I have tried to make a button which searches through a selection of data on one sheet for a ID number then returns the corresponding data in the row after onto a different sheet. I thought i had it sorted but this just wont work and have run out ideas.
Any help would be appreciated.
see code below:
Private Sub CommandButton2_Click()
Dim Userentry As String
Dim DataRange As Range
Dim i As Long
Dim location As Integer
Dim ws, ws1 As Worksheet
Set ws = Sheets("Sheet1")
Set ws1 = Sheets("Sheet4")
With TextBox2
Userentry = .Value
End With
Range("A36").Value = Userentry
For i = 2 To ws.Range("A" & Rows.Count).End(xlUp).Row
If LCase(Cells(i, 1).Value) = Userentry Then ws1.Range("F" & Rows.Count).End(xlUp).Offset(1, 0).Value = Cells(i, 2).Value
Next i
For i = 2 To ws.Range("A" & Rows.Count).End(xlUp).Row
If LCase(Cells(i, 1).Value) = Userentry Then ws1.Range("G" & Rows.Count).End(xlUp).Offset(1, 0).Value = Cells(i, 3).Value
Next i
For i = 2 To ws.Range("A" & Rows.Count).End(xlUp).Row
If LCase(Cells(i, 1).Value) = Userentry Then ws1.Range("H" & Rows.Count).End(xlUp).Offset(1, 0).Value = Cells(i, 4).Value
Next i
For i = 2 To ws.Range("A" & Rows.Count).End(xlUp).Row
If LCase(Cells(i, 1).Value) = Userentry Then ws1.Range("I" & Rows.Count).End(xlUp).Offset(1, 0).Value = Cells(i, 5).Value
Next i
End Sub
I'd throw in two possible solutions, with the goal to minimize execution time (should it be an issue)
solution 1
here you're still actually looping through column A cells but:
only if there's at least one matching value
considering non empty cells with text values only
`
Option Explicit
Private Sub CommandButton2_Click()
Dim Userentry As String, firstAddr As String
Dim ws1 As Worksheet
Dim f As Range
Set ws1 = Sheets("Sheet4")
Userentry = TextBox2.Value
ws1.Range("A36").Value = Userentry
With Sheets("Sheet1")
With .Range("A1:A" & .Cells(.Rows.Count, 1).End(xlUp).Row).SpecialCells(xlCellTypeConstants, xlTextValues)'<~~ consider column "A" cells with text values down to the LAST non empty one
Set f = .Find(What:=Userentry, LookAt:=xlWhole, LookIn:=xlValues)
If Not f Is Nothing Then '<~~ loop only if there's at least one matching value
firstAddr = f.Address
Do
ws1.Range("F" & Rows.Count).End(xlUp).Offset(1, 0).Resize(1, 4).Value = _
f.Offset(, 1).Resize(1, 4).Value
Set f = .FindNext(f)
Loop While f.Address <> firstAddr
End If
End With
End With
End Sub
`
solution 2
this avoids looping at all, but at the "expense" of sorting rows
Option Explicit
Private Sub CommandButton2_Click()
Dim Userentry As String
Dim countVal As Long
Dim ws1 As Worksheet
Set ws1 = Sheets("Sheet4")
Userentry = TextBox2.Value
ws1.Range("A36").Value = Userentry
With Sheets("Sheet1")
With .Range("A1:A" & .Cells(.Rows.Count, 1).End(xlUp).Row) '<~~ consider column "A" cells down to the LAST non empty one
countVal = Application.WorksheetFunction.CountIf(.Cells, Userentry) '<~~ count matching values
If countVal > 0 Then '<~~ if any then ...
.Resize(, 5).Sort key1:=.Range("A1"), order1:=xlDescending, Header:=xlNo '<~~ ... sort columns "A" to "E" by column "A" values...
ws1.Range("F" & Rows.Count).End(xlUp).Offset(1, 0).Resize(countVal, 4).Value = .Find(What:=Userentry, LookAt:=xlWhole, LookIn:=xlValues).Offset(, 1).Resize(countVal, 4).Value '<~~ ... and copy/paste values
End If
End With
End With
End Sub
if you should ever mind having Sheet1 rows sorted, then here's the "patch"
Private Sub CommandButton2_Click()
Dim Userentry As String
Dim countVal As Long
Dim ws1 As Worksheet
Dim helperCol As Range
Set ws1 = Sheets("Sheet4")
Userentry = TextBox2.Value
ws1.Range("A36").Value = Userentry
With Sheets("Sheet1")
Set helperCol = .UsedRange.Columns(.UsedRange.Columns.Count + 1) '<~~ set a helper column "out of the town" not to interfere with data already there
With .Range("A1:A" & .Cells(.Rows.Count, 1).End(xlUp).Row) '<~~ consider column "A" cells down to the LAST non empty one
countVal = Application.WorksheetFunction.CountIf(.Cells, Userentry) '<~~ count matching values
If countVal > 0 Then '<~~ if any then ...
With Intersect(.Rows.EntireRow, helperCol) '<~~ consider helper column rows corresponding to your data ones
.Formula = "=ROW()" '<~~ place an ascending index to every row
.Value = .Value '<~~ get rid of formulas, otherwise subsequent sorting would have no effect on their result
End With
.Resize(, helperCol.Column).Sort key1:=.Range("A1"), order1:=xlDescending, Header:=xlNo '<~~ ... sort columns "A" to "helpercol" rows by column "A" values...
ws1.Range("F" & Rows.Count).End(xlUp).Offset(1, 0).Resize(countVal, 4).Value = .Find(What:=Userentry, LookAt:=xlWhole, LookIn:=xlValues).Offset(, 1).Resize(countVal, 4).Value '<~~ ... copy/paste values ...
.Resize(, helperCol.Column).Sort key1:=helperCol, order1:=xlAscending, Header:=xlNo '<~~ ... and sort columns "A" to "helpercol" rows back by "helpercol" values
helperCol.Clear '<~~ finally clear "helpercol" column
End If
End With
End With
End Sub
Private Sub CommandButton2_Click()
Dim Userentry As String
Dim i As Long
Dim ws, ws1 As Worksheet
Set ws = Sheets("Sheet1")
Set ws1 = Sheets("Sheet4")
Userentry = TextBox2.Value
ws1.Range("A36").Value = Userentry
For i = 2 To ws.Range("A" & Rows.Count).End(xlUp).Row
If LCase(ws.Cells(i, 1).Value) = Userentry Then
ws1.Range("F" & Rows.Count).End(xlUp).Offset(1, 0).Resize(1, 4).Value = _
ws.Cells(i, 2).resize(1, 4).Value
End If
Next i
End Sub