I have complied the below code for creating a separate bank payment sheet, everything is working fine but it is not deleting the rows of the cells whose value is "Delete" in column "E".
i have also observed while debugging that sometimes it deletes and sometimes it don't.
but now it is not deleting at all.
where I'm going wrong?
Sub Create_Bank_Sheet()
Dim fname As String
Dim path As String
Dim varResponse As Variant
Application.DisplayAlerts = False
varResponse = MsgBox("Select 'Yes' or 'No' File will be Saved at : " & Range("c43").Value, vbYesNo, "Are you sure you want to SaveAs this Sheet?")
If varResponse <> vbYes Then Exit Sub
Sheets("Bank Sheet for Payment").Select
path = Sheets("Command Center").Range("c43")
fname = Sheets("Command Center").Range("c42")
ThisWorkbook.Sheets("Bank Sheet for Payment").Copy
Application.ActiveWorkbook.SaveAs Filename:=path & "\" & fname, _
FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
Cells.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Dim c As Range
Dim SrchRng As Range
Dim SrchStr As String
Set SrchRng = ActiveSheet.Range("e4", ActiveSheet.Range("e65536").End(xlUp))
SrchStr = "Delete"
Do
Set c = SrchRng.Find(SrchStr, LookIn:=xlValues)
If Not c Is Nothing Then c.EntireRow.Delete
Loop While Not c Is Nothing
ActiveWorkbook.Save
MsgBox ("File saved in " & path)
ActiveWorkbook.Close
Application.DisplayAlerts = True
End Sub
You're not setting your SrchRng correctly.
Try
Set SrchRng = ActiveSheet.Range("E4:E" & ActiveSheet.Range("E65536").End(xlUp).Row)
Related
as all i have a repeating work which i need to do on daily basis.
as i am a complete noob and my complete macro list which i have created is by reading here maybe you could help me out with one macro
is there a possiblity the macro from below to change that it will apply for all already open workbooks ?
Sub copyDown()
Dim myCount As Double
myCount = WorksheetFunction.CountA(Range("B:B"))
Range("ab2:ad" & myCount).FillDown
End Sub
Sub columnA()
Dim myfirstRow, myLastrow As Integer
myfirstRow = WorksheetFunction.CountA(Range("A:A")) + 1
myLastrow = WorksheetFunction.CountA(Range("B:B"))
Range("a" & myfirstRow & ":a" & myLastrow).Formula = "=TODAY() - 1"
Range("a" & myfirstRow & ":a" & myLastrow).Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
End Sub
both sub i need to do in 5 files where each file have 2 specific sheets
in theory i know i could arrange it a bit different but my original macro have around 1600 lines and i am afraid to touch the running macro which i have build now for 2weeks :S
thank you all
This is how to create a separate sub that will find each workbook then call your original sub, passing it the worksheet it should work on.
I've only done it for "CopyDown", but it's exactly the same process.
Option Explicit
Sub Iterate_Workbooks()
Dim WB As Workbook
For Each WB In Application.Workbooks
' This is a way to exclude open workbooks from your search
' OR remove the "not" to include withbooks with only certain
' text in their name. "*" is wildcard, see some examples:
'If Not WB.Name Like "Master*" Then
'If WB.Name Like "FillerBook # *" Then
If Not WB.Name Like "*.xlsm" Then
Call copyDown(WB.Worksheets(1))
End If
Next WB
End Sub
Sub copyDown(WS As Worksheet)
Dim myCount As Double
With WS
myCount = WorksheetFunction.CountA(.Range("B:B"))
.Range("ab2:ad" & myCount).FillDown
End With
End Sub
You can create a function that would go through all the open workbooks and from each work book it will go through all the sheets and match the name of the sheets to call your subroutines columnA and copyDown by passing the sheet reference, hope this helps!
Sub ProcessAllWorkbooks()
Dim WB As Workbook, WS As Worksheet
For Each WB In Workbooks
For Each WS In WB.Sheets
If UCase(WS.Name) = "WHATEVER_NAME_OF_COPY_DOWN_SHEET_IN_UPPERCASE" Then
Call copyDown(WS)
ElseIf UCase(WS.Name) = "WHATEVER_NAME_OF_COLUMNa_SHEET_IN_UPPERCASE" Then
Call columnA(WS)
End If
Next
Next
End Sub
Sub copyDown(processWS As Worksheet)
Dim myCount As Double
With processWS
.Activate
.Range("B1").Select
myCount = WorksheetFunction.CountA(Range("B:B"))
Range("ab2:ad" & myCount).FillDown
End With
End Sub
Sub columnA(processWS As Worksheet)
Dim myfirstRow, myLastrow As Integer
With processWS
.Activate
.Range("A1").Select
myfirstRow = WorksheetFunction.CountA(Range("A:A")) + 1
myLastrow = WorksheetFunction.CountA(Range("B:B"))
Range("a" & myfirstRow & ":a" & myLastrow).Formula = "=TODAY() - 1"
Range("a" & myfirstRow & ":a" & myLastrow).Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
End With
End Sub
Hi have been working on a method to import a text file into a specified worksheet, within a master workbook. Up until recently the file used Tab as the delimiter, which I was able to specify like so:
workbooks.open fileToOpen,,,,,,,,vbtab
now the file has switched to the use of a comma, which i have tried to specify in the line above but have been unable to get to work. im fairly new at this so not sure what my options. is there a way that I can get the code to identify the delimiter and convert based on that?
any help appreciated
copy of code :
Sub Multi_T_Import()
Dim fileToOpen, closeWorkbook, searchchar, sName As String
Dim chkFile, fileImport As Integer
Dim FinalRow As Long
Dim LastCol As Long
searchchar = "\"
'Turn off any prompts
MsgBox "Please Select Multi Token Data File" & vbNewLine & "MULTI TOKEN DATA IMPORT"
'Select the file to import
fileToOpen = Application _
.GetOpenFilename("txt Files (*.txt), *.txt")
'Option to import a different fileIf fileToOpen <> False Then
If fileToOpen <> False Then
fileImport = MsgBox("Are you sure you want to import " & fileToOpen, vbYesNo)
If fileImport = vbNo Then
MsgBox "Import of " & fileToOpen & " has been aborted"
Exit Sub
End If
End If
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Application.CutCopyMode = False
If fileImport = False Then Exit Sub
Workbooks.Open fileToOpen
Sheets.Select
If ActiveSheet.AutoFilterMode = True Then ActiveSheet.AutoFilterMode = False
FinalRow = Range("A" & Rows.Count).End(xlUp).Row
FinalRow = FinalRow + 1
Range("A1:V" & FinalRow).Select
Selection.Copy
Windows(MasterFileName).Activate
Sheets("Multi_Token_Report").Select
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'Columns("Q").Cut
'Columns("A").Insert
closeWorkbook = Mid(fileToOpen, InStrRev(fileToOpen, searchchar) + 1)
Workbooks(closeWorkbook).Close SaveChanges:=False
Dim oFS As Object
Set oFS = CreateObject("Scripting.FileSystemObject")
Range("X1").Select
ActiveCell.FormulaR1C1 = oFS.GetFile(fileToOpen).DateLastModified
Set oFS = Nothing
End Sub
There is a build-in function for separating things like comma, tab or else.
After you load in txt, it use the first column to store data. So, simply select all data on A column and use the build in function.
in VBA code, it is something like this, [ after opening txt in excel ]
Workbooks(NewWB).Sheets(1).Range("A1").EntireColumn.TextToColumns Destination:=Range("A1"), Comma:=True
enter image description here
This is a simple For ... Next so why am I getting the error, is it related to the function somehow?
The macro I supposed to find a specific worksheet within a large workbook, get some data and copy it to a separate workbook named after the worksheet. Most of this came from mw recording a macro with changes were necessary.
Dim wbThisWB As Workbook
Dim LastRow As Long
Dim WSName As String
Dim lRow As Long
Workbooks.Open Filename:= _
"\\Shenetapp01\itt viability and intervention\Assurance Work AY 17-18\AGR\Test\16-17 EY Trainees test.xls"
LastRow = wbThisWB.Worksheets("Sheet1").Cells(Row.Count, 1).End(xlUp).Row
For I = 1 To LastRow
WSName = wbThisWB.Worksheets("Sheets1").Cells(I, 1)
If sheetExists(WSName, wbThisWB) Then
MsgBox "Sheet found:" & WSName
lRow = Cells(Rows.Count, 1).End(xlUp).Row
ActiveSheet.Range("C2", "M" & lRow).Copy
Workbooks.Open Filename:="\\Shenetapp01\itt viability and intervention\Assurance Work AY 17-18\AGR\Test\" & WSName & " 17-18 AGR.xlsx"
Sheets("EY 17-18 Starters").Select
Range("C6").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
ActiveWorkbook.Save
ActiveWindow.Close
Next I
End Sub
Function sheetExists(sheetToFinad As String, wbThisWB As Workbook) As Boolean
sheetExists = False
For Each Sheet In wbThisWB.Worksheets
If sheetToFind = Sheet.Name Then
sheetExists = True
Exit Function
End If
Next Sheet
End Function
I have a task to add workbook name into all worksheet's first column hence i need to have a macro and below is a draft of the same
Sub InsertWorkbookName()
Path = "C:\Users\mechee69\Download\"
Filename = Dir(Path & "*.xls")
Do While Filename <> ""
Workbooks.Open Filename:=Path & Filename, ReadOnly:=True
For Each Sheet In ActiveWorkbook.Sheets
Columns("A:A").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Range("A1").Select
ActiveCell.SpecialCells(xlLastCell).Select
Application.Goto Range("A" & ActiveCell.Row), True
ActiveCell.Select
ActiveCell.FormulaR1C1 = _
"=RIGHT(LEFT(CELL(""filename""),FIND(""."",CELL(""filename""),FIND(""["",CELL(""filename""),1))-1),FIND(""."",CELL(""filename""),FIND(""["",CELL(""filename""),1))-FIND(""["",CELL(""filename""),1)-1)"
Application.Goto Range("A" & ActiveCell.Row), True
ActiveCell.Select
Selection.Copy
Range(Selection, Selection.End(xlUp)).Select
ActiveSheet.Paste
Application.CutCopyMode = False
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
ActiveWorkbook.Save
Next Sheet
Workbooks(Filename).Close
Filename = Dir()
Loop
End Sub
Try this
Sub WorkbookName()
Dim wbk As Workbook
Dim strFilename As String
Dim strPath As String
Dim wc As Worksheet
Dim lngLastR As Long
Dim lngSecurity as Long
lngSecurity = Application.AutomationSecurity
Application.AutomationSecurity = msoAutomationSecurityLow
strPath = "[Full Folder Path]"
strFilename = Dir(strPath & "*.xlsx")
Do While strFilename <> ""
Set wbk = Workbooks.Open(strPath & strFilename)
For Each ws In wbk.Worksheets
lngLastR = ws.Range("A" & Rows.Count).End(xlUp).Row
ws.Range("A:A").Insert Shift:=xlToRight
ws.Range("A1:A" & lngLastR).Value = wbk.Name
Next
wbk.Save
wbk.Close False
strFilename = Dir
Loop
Application.AutomationSecurity = lSecurity
MsgBox ("Done")
End Sub
As a quick run through of what this code does.
'Dir' goes through a folder on a criteria, the criteria in this case being ".xlsx" this is to make sure it only opens xlsx files.
'Do While' is a form of loop, this will repeat all code between the "Do While" and the "Loop" until the condition is no longer true.
Once deciding on the file it opens the workbook and remembers it as a variable, this is so I can reference it's name more easily.
I then find the last used row by starting at the bottom cell of row "A" and going up until there is data in a cell. There is a write up on this on stack overflow (Link: Error in finding last used cell in VBA)
I then insert a row to the left pushing the data to the right and set the value of all cells in row 'A' in the used ranged to the name of the workbook using the workbooks '.Name' function.
I then save and close the workbook before using the 'Dir' to the next file name ready to start the process again, this will repeat for all files and give you a message box saying "Done" once it has completed them all.
If you have any questions let me know
Edited to include a bypass for protected view
So this Macro will open Excel Files in a Folder with a specific format, then it prints the workbookname in A1 in every sheet of that file. It ignores the master, if its in the same folder.
Sub WorkbookName()
Dim wbk As Workbook
Dim Filename As String
Dim Path As String
Dim lastRow As Long
Dim lSecurity As Long
On Error Resume Next
Path = "C:\Users\User\Desktop\Files\" 'Folder of your Files
Filename = Dir(Path & "*.xlsx") 'Format of your files
Do While Filename <> "" And Filename <> "Master.xlsm" 'Dont Open MasterFile
Set wbk = Workbooks.Open(Path & Filename)
lSecurity = Application.AutomationSecurity
Application.AutomationSecurity = msoAutomationSecurityLow
For Each ws In wbk.Worksheets
With ws
.Range("A1").EntireColumn.Insert
lastRow = .Cells(Rows.Count, 2).End(xlUp).Row
.Range(Cells(1, 1), Cells(lastRow, 1)).Value = ActiveWorkbook.Name
End With
Application.AutomationSecurity = lSecurity
Next ws
wbk.Close True
Filename = Dir
Loop
End Sub
I am very new to the macro..
Basically I wanted to copy a row (E23 to H23) from worksheet named "Present month" of one workbook to a column of another worksheet named "ANA" (K4 to K7) in another workbook.
Please help me out!!
Edit1: Code from comment
Sub Copy_and_update_last_col_Census()
Range("K4:K7").Select
Selection.ClearContents
Application.WindowState = xlNormal
'the below line throws error
Windows("NOL_Support_Ticket_Status_Report").Activate
Range("E25:H25").Select
Selection.copy
Windows("Charts.xlsm").Activate
Range("K9").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Selection.copy
Range("K4").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Application.CutCopyMode = False
Range("K9:N9").Select
Selection.ClearContents
End Sub
This is a tip. Go to the Developers tab -> Record Macro -> do the actions you want -> stop recording and woila press alt + F11 and check out the module.
F8 is your friend and you can see what your recorded macro does!!!
try this:
Sub Copy_and_update_last_col_Census()
Dim wb As Workbook
Dim rng2copy As Range, rng2paste As Range
Dim query As Integer
Dim myfile
Dim filename As String
'~~> I assumed that Charts.xlsm is the workbook you are running the macro
Set rng2paste = ThisWorkbook.Sheets("ANA").Range("K4")
filename = "NOL_Support_Ticket_Status_Report.xlsx"
'~~> Handles the error if workbook is not open
On Error Resume Next
Set wb = Workbooks(filename)
'~~> check for error and execute action necessary
If Err.Number <> 0 Then
query = MsgBox("Source workbook not open." & vbNewLine & _
"Do you want to open it?", vbYesNo)
Else
GoTo proceedcopy
End If
If query = 6 Then
myfile = Application.GetOpenFilename(Filefilter:="Excel Files (*.xlsx), *.xlsx")
Else
MsgBox "Exiting now."
Exit Sub
End If
'~~> check if user selected the correct file
If myfile <> False Then
If Dir(myfile) = filename Then
Set wb = Workbooks.Open(myfile)
Else
MsgBox "Wrong file loaded." & vbNewLine & _
"Exiting now."
Exit Sub
End If
Else
MsgBox "No file loaded." & vbNewLine & _
"Exiting now."
Exit Sub
End If
'~~> this do the actual copying
proceedcopy:
Set rng2copy = wb.Sheets("Present Month").Range("E23", "H23")
rng2copy.Copy
rng2paste.PasteSpecial xlPasteValues, , , True
Application.CutCopyMode = False
wb.Close False
End Sub
This is tried and tested.
But i can't say that i've structured it well enough.
So i leave further testing to you.