The below code is deleting the records but I want to update the next column as "OK" instead of deleting entire row. Please advise as to what all changes are required.
Dim myFileNameDir As String
Dim ws1 As Worksheet
Dim iRow1 As Long
Dim str As String
myFileNameDir = "C:\Users\GShaikh\Desktop\Book16.xlsx"
Workbooks.Open Filename:=myFileNameDir, UpdateLinks:=0
Set ws1 = Worksheets("Students")
str = ListView1.SelectedItem.SubItems(1)
MsgBox str
With ws1
.AutoFilterMode = False
iRow1 = .Range("B" & .Rows.Count).End(xlUp).row
With .Range("B1:D" & iRow1)
.AutoFilter Field:=1, Criteria1:="=*" & str & "*"
.Offset(1, 0).SpecialCells (xlCellTypeVisible).EntireRow.Delete
End With
.AutoFilterMode = False
End With
ActiveWorkbook.Save
ActiveWorkbook.Close
You would need to remove: (xlCellTypeVisible).EntireRow.Delete
And replace it with something like Cells.Value = "OK"
Related
Can anyone please help me out, Im getting a little bit desperate
I want to search for data and then select and copy every-row up to the searched point, however I wasnt able to do this all I can do is to copy the row that includes the searched data
Sub Prehled()
Dim datarng As Range
Dim lr As Long
Dim wb As Workbook
Dim VysledekHledani As Long
Dim Obdobi As String
Application.ScreenUpdating = False
ThisWorkbook.Activate
Range("A1").Select
Obdobi = Sheets("IN7").Range("Kvartal").Value
Sheets("PomocnyList_3").Select
Sheets("PomocnyList_3").AutoFilterMode = False
lr = Sheets("PomocnyList_3").Range("A" & Rows.Count).End(xlUp).Row
Set datarng = ActiveSheet.Range("$A$1:$AZ$" & lr)
If Obdobi <> "" Then
If en_likematch = True Then
datarng.AutoFilter Field:=1, Criteria1:="=*" & Obdobi & "*", Operator:=xlAnd
Else
datarng.AutoFilter Field:=1, Criteria1:="=" & Obdobi
End If
End If
VysledekHledani = Range("A1:A" & lr).SpecialCells(xlCellTypeVisible).Count
If VysledekHledani > 1 Then
Sheets("K_report").Select
Cells.Range("B25").Value = "Test?"
Application.CutCopyMode = False
End If
If VysledekHledani > 1 Then
Sheets("PomocnyList_3").Select
Range("A2:AZ99").SpecialCells(xlCellTypeVisible).Select
ActiveSheet.AutoFilterMode = False
Selection.Copy
Sheets("K_report").Select
Range("E25").PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
End If
Application.ScreenUpdating = True
End Sub
Using Application.Match():
Sub Prehled()
Dim wsSrc As Worksheet, wb As Workbook, wsRpt As Worksheet
Dim Obdobi As String, wc As String, m
Set wb = ThisWorkbook 'best to be specific...
Set wsSrc = wb.Worksheets("PomocnyList_3")
Set wsRpt = wb.Worksheets("K_report")
wsSrc.AutoFilterMode = False
wc = IIf(en_likematch, "*", "") 'need wildcards?
Obdobi = wb.Worksheets("IN7").Range("Kvartal").Value
If Len(Obdobi) = 0 Then 'anything to search for?
MsgBox "No search term entered", vbExclamation
Exit Sub
End If
'see if there's a match in ColA
m = Application.Match(wc & Obdobi & wc, wsSrc.Columns("A"), 0)
If Not IsError(m) Then 'if not an error then we got a match
With wsSrc.Range("A2:AZ" & m)
wb.Worksheets("K_report").Range("E25").Resize(.Rows.Count, .Columns.Count).Value = .Value
End With
End If
End Sub
I am trying to copy a filtered range from a master dataset to a spreadsheet for each country (loop). I am getting a type mismatch error for Set rng1 = ws2.Range("E2:L" And lRow1) when I set a range in the filtered sheet. Can someone please help me identify the cause of the mismatch?
Sub CopyData_To_TemplateWorkbook2()
Dim wb As Workbook
Dim SavePath, TemplatePath, TemplateFile As String
Dim ws1, ws2, ws3, wbws1, wbws2, wbws3 As Worksheet
Dim rng1, rng2 As Range
Dim MSi As Variant
Dim lRow1, lRow2 As Long
Application.DisplayAlerts = False
'Application.ScreenUpdating = False
TemplatePath = "C:\Users\xyz\Test\"
TemplateFile = "Template_blank.xlsx"
SavePath = "C:\Users\xyz\Test\"
Set ws1 = ThisWorkbook.Sheets("Lists")
Set ws2 = ThisWorkbook.Sheets("Responses 2006 2020")
ws1.Select
For i = 2 To 5 'Loop through list of country names
Set MSi = ws1.Range("A" & i)
ws2.Activate
If ActiveSheet.FilterMode Then
ActiveSheet.ShowAllData
End If
ws2.Range("B1").AutoFilter Field:=2, Criteria1:=MSi 'Filter Criteria1 = i
lRow1 = ws2.Range("E" & Rows.Count).End(xlUp).Row
Set rng1 = ws2.Range("E2:L" And lRow1) 'Type mismatch here
'Set rng1 = ws2.Range("E2:L") 'Application-defined or object-defined error here if used
Set wb = Workbooks.Open(Filename:=TemplatePath & "Template_blank.xlsx", Editable:=True)
Set wbws1 = wb.Sheets("Cover sheet")
Set wbws2 = wb.Sheets("Responses")
wbws1.Range("B2").Value = MSi
wbws2.Range("B2").Value = MSi
lRow2 = wbws2.Range("A" & Rows.Count).End(xlUp).Row 'But there is no last row - blank sheet
Set rng2 = wbws2.Range("A6:H") ' And lRow2 ??
rng2.Value = rng1.Value
wb.SaveAs Filename:=SavePath _
& MSi & "_text" & Format(Date, "yyyymmdd") & ".xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
wb.Close SaveChanges:=False
Set rng1 = Nothing
ws1.Select
Next i
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
I'm very new to VBA and trying to write a macro, that filters by "Country", then copies it, creates new document, paste it there and save file based on "ID".
I keep getting
run-time error 1004 its sorry we couldn't find... or microsoft can't access the file
Can anyone help? that the code I've got
Sub filter()
Application.ScreenUpdating = False
Dim x As Range
Dim rng As Range
Dim last As Long
Dim sht As String
Dim ID As String
ID = Range("a2")
'specify sheet name in which the data is stored
sht = "Master"
'change filter column in the following code
last = Sheets(sht).Cells(Rows.Count, "H").End(xlUp).Row
Set rng = Sheets(sht).Range("A1:Y" & last)
Sheets(sht).Range("H1:H" & last).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("AA1"), Unique:=True
For Each x In Range([AA2], Cells(Rows.Count, "AA").End(xlUp))
With rng
.AutoFilter
.AutoFilter Field:=8, Criteria1:=x.Value
.SpecialCells(xlCellTypeVisible).Copy
Workbooks.Add
ActiveSheet.Paste
ActiveWorkbook.SaveCopyAs filename:=Environ("userprofile") & "\OneDrive - \Desktop\VBA macro\ split by country" & ID & ".xlsm"
ActiveWorkbook.Close
End With
Next x
' Turn off filter
Sheets(sht).AutoFilterMode = False
With Application
.CutCopyMode = False
.ScreenUpdating = True
End With
End Sub
I am new to macro.
I have written macro code to add the rows based on filter from the macro enabled excel file and copy the results in new excel file.
I have VBS to run the macro.
My problem is
when I run the macro from the xlsm file ,it is running only once and the values are stored correctly by creating the xlsx file
But when I run the same macro from VBS, macro is running multiple times with error msg which is posted below
My Macro is :
Sub SuppOSCalculation()
Dim wb As Workbook
Dim src As Worksheet
Dim tgt As Worksheet
Dim filterRange As Range
Dim lastRow As Long
Dim lastCol As Long
Dim Total As Double
Dim AddRange As Range
Dim c As Variant
Dim list As Object, item As Variant
Dim i As Integer
spath = "Mypath\"
sFile = spath & "supp.xlsm"
Set wb = Workbooks.Open(sFile)
SendKeys "{Enter}"
Set src = wb.Sheets("supp")
Set tgt = wb.Sheets("Sheet3")
Set list = CreateObject("System.Collections.ArrayList")
i = 2
' turn off any autofilters that are already set
src.AutoFilterMode = False
' Copy all fileds to second sheet and remove duplicates
src.Range("C3:C" & Cells(Rows.Count, "C").End(xlUp).Row).Copy tgt.Range("A2")
tgt.Range("A2:A" & Cells(Rows.Count, "A").End(xlUp).Row).RemoveDuplicates Columns:=1, Header:=xlNo
' Add all values in Second sheet to a list
With tgt
For Each item In .Range("A2", .Range("A" & .Rows.Count).End(xlUp))
If Not list.Contains(item.Value) Then list.Add item.Value
Next
End With
tgt.Range("A1").Value = "Supplier GL Code"
tgt.Range("B1").Value = "Supplier OS Report-Invoice Amount"
' find the last row and Column with data in column A
lastRow = src.Range("A" & src.Rows.Count).End(xlUp).Row
lastCol = src.Cells(1, Columns.Count).End(xlToLeft).Column
'MsgBox lastCol
' the range that we are auto-filtering (all columns)
Set filterRange = src.Range("A2:AF2" & lastRow)
For Each item In list
'From List set the value for the filter
' MsgBox (item)
filterRange.Range("C2").AutoFilter field:=3, Criteria1:=item
'Add the column value after applying filter
Set AddRange = src.Range("P3:P" & src.Range("P" & Rows.Count).End(xlUp).Row)
Total = WorksheetFunction.Sum(AddRange.SpecialCells(xlCellTypeVisible))
'MsgBox (Total)
tgt.Range("B" & i).Value = Total
i = i + 1
Next
'src.AutoFilterMode = False
'wb.Close SaveChanges:=True
Dim lRow, lCol As Integer
tgt.Select
lRow = Range("A" & Rows.Count).End(xlUp).Row
lCol = Cells(1, Columns.Count).End(xlToLeft).Column
For Each cell In Range(Cells(1, "B"), Cells(1, lCol))
Union(Range("A2:A" & lRow), Range(Cells(2, cell.Column), Cells(lRow, cell.Column))).Copy
Workbooks.Add
Range("A1").PasteSpecial
ActiveWorkbook.SaveAs Filename:= _
"SupOSTBCalc\" & cell.Value & ".xlsx" 'You might want to change the extension (.xls) according to your excel version
Next cell
ActiveWorkbook.Close
Application.CutCopyMode = False
'wb.Close
' Application.DisplayAlerts = False
' Application.AlertBeforeOverwriting = False
' Application.ScreenUpdating = False
' SendKeys "{Enter}"
wb.Close savechanges:=False
End Sub
VBS is:
Dim xlApp
Dim xlBook
Set xlApp = CreateObject("Excel.Application")
Set xlBook = xlApp.Workbooks.Open("Mypath\SupOSTBCalc.xlsm")
xlApp.Run "Module1.SuppOSCalculation"
'xlBook.Save
xlBook.Close
xlApp.Quit
Set xlBook = Nothing
Set xlApp = Nothing
Error msg is
Pls help me to solve this.
I'm running into an issue with looping through tabs in my workbook. The code I am working on is supposed to perform the following:
Loop through all worksheets except the ones titled "BOAT" & "Data"
Select cell "A2" (A2 contains the value to filter)in each worksheet that it is looping through and use it as the autofilter value for the "Data" tab
Then copy and paste the filtered data into the respective tab that is looping through.
The issue I am running into is my code isn't picking up on the active sheet in the loop. Is there a way to create a variable to for the worksheet currently being looped through?
Code below. Thank you!
Sub updatedata()
Dim ws As Worksheet
Dim wsheet2 As Worksheet
For Each ws In ActiveWorkbook.Worksheets
If ws.name <> "BOAT" And ws.name <> "Data" Then
Call filter1
End If
Next ws
End Sub
Sub filter1()
Dim lastrow As Long
Dim lastrow2 As Long
Dim wSheet As Worksheet
Dim rInput As String
Application.DisplayAlerts = False
Set wSheet = ActiveSheet
rInput = wSheet.Range("A2").Value
Sheets("Data").Activate
lastrow = Range("A" & Rows.Count).End(xlUp).Row
ActiveSheet.Range("A1:Y" & lastrow).AutoFilter field:=4, Criteria1:="=*" & rInput & "*"
lastrow2 = Range("G" & Rows.Count).End(xlUp).Row
Range("G1:G" & lastrow2).Copy
wSheet.Activate
Range("A4").PasteSpecial xlPasteValues
Rows(4).EntireRow.Delete
Application.DisplayAlerts = True
End Sub
"Is there a way to create a variable to for the worksheet currently being looped through?"
Yes, using a Worksheet variable as an argument in filter1.
Avoid using Activate or making Range calls without specifying the Worksheet.
Sub updateData()
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Worksheets
If ws.Name <> "BOAT" And ws.Name <> "Data" Then
filter1 ws 'no need to use Call
End If
Next ws
End Sub
By passing ws as an Argument to filter1, all Range calls are fully qualified with the Worksheet in question. This is easily accomplished with a With...End With block - note the period . in front of .Range("A2").Value, .Range("A4"), etc - equivalent to myWs.Range("A2").Value, myWs.Range("A4")..., etc.
Sub filter1(myWs As Worksheet)
Dim lastRow As Long, lastRow2 As Long
Dim rInput As String
Application.DisplayAlerts = False
With myWs
rInput = .Range("A2").Value
With .Parent.Sheets("Data")
lastRow = .Range("A" & .Rows.Count).End(xlUp).Row
.Range("A1:Y" & lastRow).AutoFilter field:=4, Criteria1:="=*" & rInput & "*"
lastRow2 = .Range("G" & .Rows.Count).End(xlUp).Row
.Range("G1:G" & lastRow2).Copy
End With
.Range("A4").PasteSpecial xlPasteValues
.Rows(4).EntireRow.Delete
End With
Application.DisplayAlerts = True
End Sub