Autofilter then Copy and Paste Range
I wrote a code below. Intention is to autofilter column K with criteria, copy data and paste it at the bottom of the sheet on the same page, just below the last row.
I am not getting any error, but code is not working as intended. It works up to autofilter and copy, but it won't paste the data to the last row. Can I please get some assistance.
Sub Depreciation_to_Zero() With Sheets("Restaurant") .AutoFilterMode = False With .Range("k1", .Range("k" & .Rows.Count).End(xlUp)) .AutoFilter Field:=1, Criteria1:="*HotDog*" On Error Resume Next .Offset(1).SpecialCells(xlCellTypeVisible).EntireRow.Copy .Cells(.Rows.Count, "A").End(xlUp).Row.Select.PasteSpecial xlPasteValues On Error GoTo 0 End With .AutoFilterMode = False End With MsgBox ("Complete") End Sub
Try this version
Option Explicit Public Sub DepreciationToZero() Const FIND_VAL = "*HotDog*" Dim ws As Worksheet, lr As Long, result As String Set ws = Worksheets("Restaurant") Application.ScreenUpdating = False ws.AutoFilterMode = False lr = ws.Cells(ws.Rows.Count, "K").End(xlUp).Row result = FIND_VAL & " not found" With ws.UsedRange ws.Range("K1:K" & lr).AutoFilter Field:=1, Criteria1:=FIND_VAL If ws.Range("K1:K" & lr).SpecialCells(xlCellTypeVisible).CountLarge > 1 Then .Offset(1).Resize(lr - 1).SpecialCells(xlCellTypeVisible).Copy .Offset(lr).Cells(1).PasteSpecial xlPasteValues .Offset(lr).Cells(1).Select Application.CutCopyMode = False result = "All " & FIND_VAL & " rows copied" End If End With ws.AutoFilterMode = False Application.ScreenUpdating = True MsgBox result End Sub
See also questions close to this topic
Can R identify the excel commented cells?
I have an excel sheet .xlsx, which have some commented cells in it. After importing it in R, is there any way by which R can identify the commented cells? Because I have to use some if else conditions only to the commented cells.
Copy only visible data entries in Excel, but something is going wrong, why?
I'm looking to create a bit of VBA code that copies two columns of only visible data on all excel workbooks in a file.
For example, I might have this data visible (left number is column A, right is in column 2):
- 1 2
- 1 3
- 1 4
- 1 5
but the code I use merely copies 1 2 for this worksheet or, if there is a duplicate, as in
- 1 2
- 1 2
- 1 3
then it only copies the first duplicated values. I've posted the code I'm using below. What is going on?
Sub MergeAllWorkbooks() Dim SummarySheet As Worksheet Dim FolderPath As String Dim NRow As Long Dim FileName As String Dim WorkBk As Workbook Dim SourceRange As Range Dim DestRange As Range Set SummarySheet = Workbooks.Add(xlWBATWorksheet).Worksheets(1) FolderPath = "This is my folder path" NRow = 1 FileName = Dir(FolderPath & "*.xl*") Do While FileName <> "" Set WorkBk = Workbooks.Open(FolderPath & FileName) SummarySheet.Range("A" & NRow).Value = FileName Set SourceRange = WorkBk.Worksheets(1).Range("B1:B100").SpecialCells(xlCellTypeVisible) Set DestRange = SummarySheet.Range("C" & NRow) Set DestRange = DestRange.Resize(SourceRange.Rows.Count, _ SourceRange.Columns.Count) DestRange.Value = SourceRange.Value NRow = NRow + DestRange.Rows.Count WorkBk.Close savechanges:=False FileName = Dir() Loop SummarySheet.Columns.AutoFit End Sub
Importing multiple sections and sub data lines from text into specific columns
Found this and it helps but does quite get the complexity that I require. How to import specific text from files in to excel?
What i am doing is scanning a range of IPs with another script which will create a single text file for each server with that server's hardware profile. That script is not the problem and works correctly at this time.
Then I want a script that will loop through all of the files created above and import only specific data into an Excel spreadsheet.
Sub ReadFilesIntoActiveSheet() Dim fso As FileSystemObject Dim folder As folder, file As file, FileText As TextStream Dim TextLine As String Dim cl As Range Dim num As Long ' numerical part of key, as in "Ann:" Dim col As Long ' target column in Excel sheet Dim key As String ' Part before ":" Dim value As String ' Part after ":" ' Get a FileSystem object Set fso = New FileSystemObject ' Get the directory you want Set folder = fso.GetFolder("D:\YourDirectory\") ' Set the starting point to write the data to ' Don't write in first row where titles are Set cl = ActiveSheet.Cells(2, 1) ' Loop thru all files in the folder For Each file In folder.Files ' Open the file Set FileText = file.OpenAsTextStream(ForReading) ' Read the file one line at a time Do While Not FileText.AtEndOfStream TextLine = FileText.ReadLine 'read line key = Split(TextLine & ":", ":")(0) value = Trim(Mid(TextLine, Len(key)+2)) num = Val(Mid(key,2)) If num Then key = Replace(key, num, "") ' Remove number from key col = 0 If key = "From" Then col = 1 If key = "Date" Then col = 2 If key = "A" Then col = 2 + num If col Then cl.Offset(, col-1).Value = value ' Fill cell End If Loop ' Clean up FileText.Close ' Next row Set cl = cl.Offset(1) Next file End Sub
The way I import that file into Excel looks similar to this:
This is a small clip of a long file with lots of sections. This clip shows clips of 2 sections. I need this vba script to be able to determine the  section and then pull a specific line under that. And there are many sections that may be nearly identical such as
[InstanceID: DIMM.Socket.A2]and many of the sub lines may be the same as well such as Model may be listed under many different types of components.
How can this script go through and pull the Model from under
[InstanceID: DIMM.Socket.A1]but skip all of the rest of the similar sections. And then pull BIOSReleaseDate and BIOSVersionString lines from the
[InstanceID: System.Embedded.1]section. I assume I can use the rest of the original script to put these data points into specific columns such as
Then col = 1or
Then col = A.
VBA Outlook Run-time Error - Could not send the message
The VBA code shown below is for replying to an email with a specific template. The user selects the email that they want to reply to through a file dialog box, the code should then open a new email replying to the selected email. I am receiving the following error:
Run-time error '-2147352567 (80020009)' Could not send the message.
When I click the "Help" button it takes me here: https://msdn.microsoft.com/en-us/VBA/Outlook-VBA/articles/olkcategory-backcolor-property-outlook
I can't imagine that link has anything to do with the error though. I have a feeling I'm doing something wrong with adding the reply email. Any help would be appreciated.
Here is my code:
Public Sub btnOK_Click() Dim myOlApp As Outlook.Application Dim myItem As Outlook.MailItem Dim body As String Set myOlApp = CreateObject("Outlook.Application") Select Case templateUserForm.templateListBox.Text Case "CWO" ReplyTo Set myItem = myOlApp.CreateItemFromTemplate("C:\example\temp\tempEmail.msg") myItem.Reply = myOlApp.CreateItemFromTemplate("L:\example\CWO.oft") <--- Error occurs on this line body = myItem.body Unload templateUserForm Unload inputUserForm myItem.Display End Select End Sub Public Sub ReplyTo() Dim fso As Object Dim xlApp As Object Set xlApp = CreateObject("Excel.Application") xlApp.Visible = False Dim fd As Office.FileDialog Set fd = xlApp.Application.FileDialog(msoFileDialogFilePicker) fd.AllowMultiSelect = False Dim selectedItem As Variant If fd.Show = -1 Then For Each selectedItem In fd.SelectedItems Set fso = VBA.CreateObject("Scripting.FileSystemObject") Call fso.CopyFile(fd.SelectedItems.Item(1), "C:\example\temp\tempEmail.msg") Next End If End Sub
Deselecting a checkbox when another is checked
I have two checkboxes, form controls, if I select one, the other one is deselected. I cannot use ActiveX controls because there are many other checkboxes from other sheets are form controls. I cannot use option button because I need to get "true" "false" value.
I used this code below:
Private Sub CheckBox1_Click() If CheckBox1.Value = True Then CheckBox2.Value = False CheckBox2.Enabled = False Else CheckBox2.Enabled = True End If End Sub Private Sub CheckBox2_Click() If CheckBox2.Value = True Then CheckBox1.Value = False CheckBox1.Enabled = False Else CheckBox1.Enabled = True End If End Sub
But it shows
Run-time error '424', Object required
I am very new to VBA and still learning. I have no idea to fix it, please help me!! Thank you very much!!
Change Multiple Cell Interior Colors With a Function
How can I create a function to be used in a conditional logic statement to act as a result?
Conditional logic statement:
=IF(COUNTIFS(B10:B147,">20")=0,"Ok",function())Result2[function()]: Change each cell
B10:B147to red if value within cell is over 20.
Pasting file name at the end of each row
I am trying to copy values from few excel files into one. I am trying to achieve that by first looping through directories and then files.
For Each cell In ThisWorkbook.Sheets("Info").Range("b8:b9") MsgBox (cell) strfile = Dir$(cell & "\" & "*.xlsm", vbNormal) While strfile <> "" MsgBox (strfile) ' Open the file and get the source sheet Set wbSource = Workbooks.Open(cell & "\" & strfile) Set inSource = wbSource.Sheets("OUTPUT_INSTRUMENT") Set enSource = wbSource.Sheets("OUTPUT_ENTITY") Set prSource = wbSource.Sheets("OUTPUT_PROTECTION") 'Copy the data Call CopyHeaders(inSource, inTarget, enSource, enTarget, prSource, prTarget) Call CopyData(inSource, inTarget, enSource, enTarget, prSource, prTarget) 'Close the workbook and move to the next file. wbSource.Close False strfile = Dir$() Wend Next cell
Those are the values in B8:B9
So when I copy the headers I am also adding additional column at the end. For each row pasted I need to add the source path (strfile) at the last column. I am trying with this but it doesn't work:
targetSht.Range(targetSht.Columns.Count & targetSht.Rows.Count).End(xlUp).Offset(1, 0).Value = strfile
Please find the additional definitions below. Source sheets are looped through the directory.
Set inTarget = ThisWorkbook.Sheets("Instrument") Set enTarget = ThisWorkbook.Sheets("Entity") Set prTarget = ThisWorkbook.Sheets("Protection") Sub CopyData(ByRef inSource As Worksheet, inTarget As Worksheet, enSource As Worksheet, enTarget As Worksheet, prSource As Worksheet, prTarget As Worksheet) CopySingleSheetData inSource, inTarget CopySingleSheetData enSource, enTarget CopySingleSheetData prSource, prTarget End Sub Sub CopySingleSheetData(sourceSheet As Worksheet, targetSht As Worksheet) With sourceSheet Intersect(.UsedRange, .Rows(5).Resize(.UsedRange.Rows.Count)).Copy End With targetSht.Range("A" & targetSht.Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValuesAndNumberFormats targetSht.Range(targetSht.Columns.Count & targetSht.Rows.Count).End(xlUp).Offset(1, 0).Value = "dsdf" Application.CutCopyMode = xlCopy End Sub
VB Copy SpecialPaste
Team- Here is what I got. I found this bit of code and it works ok. However, L55 and L57 when copied and pasted end up as formulas not as values. I tried tacking on the PasteSpecial PasteValuesx1 but I think I may have painted myself into a corner by the way that I set it up. Many thanks.
Dim ws1 As Worksheet, ws2 As Worksheet Dim DestRow As Long Set ws1 = Sheets("DAILY SCRAP") Set ws2 = Sheets("GROSS TONS") DestRow = ws2.Cells(Rows.Count, "A").End(xlUp).Row + 1 ws1.Range("L55").Copy ws2.Range("C" & DestRow) ws1.Range("L56").Copy ws2.Range("B" & DestRow) ws1.Range("L57").Copy ws2.Range("D" & DestRow) ws1.Range("L1").Copy ws2.Range("A" & DestRow)
Paste values into new sheets using for Loop
I am attempting to create new tabs based on a table of information. The title of the tab each tab is in a specific column (each row having a separate title). In the respective row, there is also information I'd like to have copied into the new sheet that is created for that title. I've gotten the new sheets/renaming down with the following code.
Sub test_tableTOtabs2() Application.ScreenUpdating = False Dim fr As Integer Dim lr As Integer Dim col As String Dim val1 As String Dim val2 As String fr = Application.InputBox("Starting row of data: ", Default:=2, Type:=1) lr = Application.InputBox("Last row of data: ", , Default:=2, Type:=1) col = Application.InputBox("Column for Tab titles: ", Default:="A", Type:=2) val1 = Application.InputBox("Column for Value start: ", Default:="B", Type:=2) val2 = Application.InputBox("Column for Value end: ", Default:="C", Type:=2) Dim BaseSheet As Worksheet Set BaseSheet = ActiveSheet Dim i As Integer Dim TitleCell As String Dim title As String Dim ws As Worksheet Dim x As Integer For i = fr To lr On Error Resume Next TitleCell = CStr(col & CStr(i)) title = Left(Replace(CStr(ActiveSheet.Range(TitleCell).Value), "/", "_"), 30) Set ws = Sheets.Add(After:=Sheets(Sheets.Count)) ws.Name = title If Err.Number <> 0 Then MsgBox "Error on row " & i End If For x = ToColNum(val1) To ToColNum(val2) Worksheets(title).Cells(1, x).Value = Worksheets(BaseSheet).Cells(i, x).Value Next BaseSheet.Select Next Application.ScreenUpdating = True End Sub
(Note: I've defined the ToColNum function as a Range(ColN & 1).Column in order to reference the column letters as numbers for incrementing)
This code accurately creates new tabs and renames them with the corresponding "Title" from the basetable (this can be considered similar to a table of contents). However, it does not paste the values of the row into the corresponding new sheet.
vba autofilter for blank and all dates this year
I have been trying to use VBA to filter a particular column for any dates in current year (dynamic) PLUS any blank cells.
This is what I have:
ActiveSheet.Range("A1", "HZ" & LastRow).AutoFilter Field:=60, Criteria1:="=", Operator:=xlOr, Criteria2:=xlFilterThisYear, Operator:=xlFilterDynamic
Criteria1 filters for blanks and criteria2 dynamically filters for this year.
When used seperately, they both work, but when I want them both to work together, only the firast criteria works. BTW, I have tried xlAnd and xlOr just in case!!
When I recorded the macro to do this, I had the following statement recorded:
ActiveSheet.Range("A1", "HZ" & LastRow).AutoFilter Field:=60, Criteria1:=Array("="), Operator:=xlFilterValues, Criteria2:=Array(0, "3/2/2018").
This works, but as you can see, there is a hard date in there, which I would need to change every week, so I would like a better solution.
Export Filtered Worksheet as CSV File
I am currently using this code to export the whole sheet, but I would like to only export the rows where a condition is met. In this case in Column 13 there is an "x":
Option Explicit Sub ExportAsCSV() Dim MyFileName As String Dim CurrentWB As Workbook, TempWB As Workbook Set CurrentWB = ActiveWorkbook ActiveWorkbook.ActiveSheet.UsedRange.Copy Set TempWB = Application.Workbooks.Add(1) With TempWB.Sheets(1).Range("A1") .PasteSpecial xlPasteValues .PasteSpecial xlPasteFormats End With Dim Change below to "- 4" to become compatible with .xls files MyFileName = CurrentWB.Path & "\" & Left(CurrentWB.Name, Len(CurrentWB.Name) - 5) & ".csv" Application.DisplayAlerts = False TempWB.SaveAs Filename:=MyFileName, FileFormat:=xlCSV, CreateBackup:=False, Local:=True TempWB.Close SaveChanges:=False Application.DisplayAlerts = True End Sub
I tried to adapt the code with an autofilter but was not successful. I replaced the line
ActiveSheet.Range("$A$1:$M$81").AutoFilter Field:=13, Criteria1:="x" Range(Selection, Selection.End(xlToRight)).Select Range(Selection, Selection.End(xlDown)).Select Selection.Copy
But I am getting the Autofiltermethod of Range Class failed error.
AutoFilter connect with and/or
I have a huge data sheet which I want to "AutoFilter" by three different criteria which are in three different columns.
Is it possible in Excel VBA to connect three AutoFilters with a logic like:
Criteria 1 AND (Criteria2 AND/OR Criteria3)
For example, I am analiyzing football teams by league, market value, revenue. Therefore, I want to filter my data by following criterias:
Criteria 1: They have to play in the highest league in their country AND (Criteria 2: Market Value most be >= 300 Mio AND/OR Criteria 3: Revenue most be >= 100 Mio )
Thank you :)