I am using excel VBA to create a new sheet then copy data from another sheet to this new sheet I created. Then I will format the new sheet by deleting some columns and text wrapping. It does the job alright However it is not efficient: The screen flickers so much despite using Application.DisplayAlerts = False, Application.EnableEvents = False.
Any help?
Sub ProcessPostingData()
Dim MyDateTime As String
Dim szToday As String
Dim szTime As String
Dim TD, TM As String
Dim AfterFilterFinalRow As Long
Dim lLastRow3nd As Long
Application.DisplayAlerts = False
Application.EnableEvents = False
On Error Resume Next
Sheets("szTempNow").Delete
On Error GoTo 0
Sheets.Add().Name = "szTempNow"
Worksheets("DATA_PROCESSING").Select
lLastRow3nd = Cells(1, 6).EntireColumn.Find("*", SearchDirection:=xlPrevious).Row
'We sort,create sheet with DateTime stamp,copy data to new sheet and format
ActiveWorkbook.Worksheets("DATA_PROCESSING").Range(Cells(1, 1), Cells(lLastRow3nd, 10)).Sort _
Key1:=Range("A1"), Header:=xlYes
With Worksheets("DATA_PROCESSING")
AfterFilterFinalRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
Sheets("DATA_PROCESSING").Range("A1:J1").Copy Destination:=Sheets("szTempNow").Range("A1")
Sheets("szTempNow").Range("A2:J" & AfterFilterFinalRow).Value = Sheets("DATA_PROCESSING").Range("A2:J" & AfterFilterFinalRow).Value
Sheets("DATA_PROCESSING").Range(Cells(2, 1), Cells(AfterFilterFinalRow, 10)).EntireRow.Delete
'Removing columns not needed and formating
Sheets("szTempNow").Select
'With Sheets("szTempNow")
.Columns("G:G").Delete Shift:=xlToLeft
.Columns("D:E").Delete Shift:=xlToLeft
End With
'With Range(Cells(1, 1), Cells(AfterFilterFinalRow, 10))
'.HorizontalAlignment = xlGeneral
'.VerticalAlignment = xlCenter
'.WrapText = True
'.ReadingOrder = xlContext
'End With
'Range("E2:E" & AfterFilterFinalRow).Columns("E:E").ColumnWidth = 70
'Rename Sheet with Todays date and Time
szTime = Format(Time, "h-mm AM/PM")
szToday = Format(Now(), "dd-mmm-yyyy")
TD = "D"
TM = "T"
MyDateTime = TD & szToday & TD & "_" & TM & szTime & TM
ActiveSheet.Name = MyDateTime
Range("K1").Value = ActiveSheet.Name
Range("K1").Font.Bold = True
With Range("K1")
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlCenter
.ReadingOrder = xlContext
End With
Application.EnableEvents = False
Application.DisplayAlerts = True
End Sub
You are looking for:
Application.ScreenUpdating = False
That's the one that helps stop screen flickering, and can also speed up processing. Application.DisplayAlerts suppresses dialogs along the lines of "This Workbook is Unsaved."
Related
I need to check if a list of files exist in a certain directory, based on cell values in Excel.
If some files are not found, a message box displays the names of the files that were not found.
I'm unclear if you want to see the files listed in the range that do not appear in the folder or if you want to see the files in the folder that are not in the range.
The following example lists the files in the range that are not in the folder.
I've set up a page for the example, so you may need to adjust your sheet to match, or adjust your code to fit your sheet. Be sure that the folder path you put in B1 has the trailing backslash.
Here's the code:
Sub files_in_folder()
Dim folder As String
Dim filename As String
Dim filenames As Range
Dim cell As Range
Dim s As Worksheet
Dim missing As New Collection
Dim message As String
Dim x As Integer
Set s = ActiveSheet
folder = s.Range("b1").Value
Set filenames = Range(s.Range("b2"), s.Range("b2").End(xlDown))
For Each cell In filenames
If Dir(folder + cell.Value) = "" Then missing.Add cell.Value
Next
If missing.Count = 0 Then
message = "All files were found in " & folder
Else
message = "The following files were not found in " & folder & vbNewLine
For x = 1 To missing.Count
message = message + " " + missing(x) & vbNewLine
Next
End If
MsgBox message
End Sub
Try this.
Sub TestListFilesInFolder()
' Open folder selection
' Open folder selection
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Select a Folder"
.AllowMultiSelect = False
If .Show <> -1 Then GoTo NextCode
pPath = .SelectedItems(1)
If Right(pPath, 1) <> "\" Then
pPath = pPath & "\"
End If
End With
Application.WindowState = xlMinimized
Application.ScreenUpdating = False
Workbooks.Add ' create a new workbook for the file list
' add headers
ActiveSheet.Name = "ListOfFiles"
With Range("A2")
.Formula = "Folder contents:"
.Font.Bold = True
.Font.Size = 12
End With
Range("A3").Formula = "File Name:"
Range("B3").Formula = "File Size:"
Range("C3").Formula = "File Type:"
Range("D3").Formula = "Date Created:"
Range("E3").Formula = "Date Last Accessed:"
Range("F3").Formula = "Date Last Modified:"
Range("A3:F3").Font.Bold = True
Worksheets("ListOfFiles").Range("A1").Value = pPath
Range("A1").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With
With Selection.Font
.Color = -16776961
.TintAndShade = 0
End With
Selection.Font.Bold = True
ListFilesInFolder Worksheets("ListOfFiles").Range("A1").Value, True
' list all files included subfolders
Range("A3").Select
Lastrow = Range("A1048576").End(xlUp).Row
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
ActiveWorkbook.Worksheets("ListOfFiles").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("ListOfFiles").Sort.SortFields.Add Key:=Range( _
"B4:B" & Lastrow), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:= _
xlSortNormal
With ActiveWorkbook.Worksheets("ListOfFiles").Sort
.SetRange Range("A3:F" & Lastrow)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Range("A1").Select
Cells.Select
Cells.EntireColumn.AutoFit
Columns("A:A").Select
Selection.ColumnWidth = 100
Range("A1").Select
NextCode:
MsgBox "No files Selected!!"
End Sub
Sub ListFilesInFolder(SourceFolderName As String, IncludeSubfolders As Boolean)
' lists information about the files in SourceFolder
Dim FSO As Scripting.FileSystemObject
Dim SourceFolder As Scripting.Folder, SubFolder As Scripting.Folder
Dim FileItem As Scripting.File
Dim r As Long
Set FSO = New Scripting.FileSystemObject
Set SourceFolder = FSO.GetFolder(SourceFolderName)
r = Range("A1048576").End(xlUp).Row + 1
For Each FileItem In SourceFolder.Files
' display file properties
Cells(r, 1).Formula = FileItem.Path & FileItem.Name
Cells(r, 2).Formula = (FileItem.Size / 1048576)
Cells(r, 2).Value = Format(Cells(r, 2).Value, "##.##") & " MB"
Cells(r, 3).Formula = FileItem.Type
Cells(r, 4).Formula = FileItem.DateCreated
Cells(r, 5).Formula = FileItem.DateLastAccessed
Cells(r, 6).Formula = FileItem.DateLastModified
' use file methods (not proper in this example)
r = r + 1 ' next row number
Next FileItem
If IncludeSubfolders Then
For Each SubFolder In SourceFolder.SubFolders
ListFilesInFolder SubFolder.Path, True
Next SubFolder
End If
Columns("A:F").AutoFit
Set FileItem = Nothing
Set SourceFolder = Nothing
Set FSO = Nothing
ActiveWorkbook.Saved = True
End Sub
Result:
I'm really new to VBA coding. So my work requires a worksheet or form to be printed out for every production received. The current worksheet works great in generating out the form with all the details required. However, we have to batch print as we received up to 100 production at a time and its very manual to print each one. We will change the "Job number" and print it out. So I was wondering if there is any ways we could print out all at once. Take note its only one sheet each for 100 items. A loop maybe?
I will be really grateful if you have any solution to this.
Thank you
enter code here
Private Sub CommandButton3_Click()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim sh As Worksheet
Set sh = ThisWorkbook.Sheets("STEP 1. JTW")
Set step2 = ThisWorkbook.Sheets("STEP 2. Repackaging Worksheet")
Dim n As Long, first As Long, Endd As Long
Dim lastrow As Long
Dim curvis As Long
n = Application.Match(VBA.CLng(Me.ComboBox2.Value), sh.Range("a:a"),0)
sh.Unprotect "udp"
step2.Unprotect "repackagingworksheet"
If Me.TextBox8.Value = "" Then
MsgBox "Please enter name!", vbCritical
Exit Sub
End If
Endd = Me.ComboBox3.Value
first = Me.ComboBox2.Value
sh.Range("L" & n).Value = Me.TextBox8.Value
sh.Range("M" & n).Value = Format(Now, "dd mmm yyyy hh:mm:ss")
For first = Me.ComboBox2.Value To Endd
step2.Range("f2").Value = Me.ComboBox2.Value
step2.Range("f2").Value = first
sh.Range("L" & first).Value = Me.TextBox8.Value
sh.Range("M" & first).Value = Format(Now, "dd mmm yyyy
hh:mm:ss")
With step2
.curvis = .Visible
.Visible = xlSheetVisible
.PageSetup.PrintArea = "$A$1:$D$47"
.PrintOut copies:=1, IgnorePrintAreas:=False
.Visible = curvis
End With
Next first
ActiveWorkbook.Save
Me.Hide
sh.Protect "udp", AllowFiltering:=True
step2.Protect "repackagingworksheet"
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Whenever I run this code, it generates a sequential number.
I want to display the new sequential number in a MsgBox, but it prints the older sequential number.
Private Sub ToggleButton1_Click()
Dim reponse As VbMsgBoxResult
Dim REVISIONRNCAUTO As Workbook
Dim Sheet2 As Worksheet
Dim cell_value As String
Set REVISIONRNCAUTO = ActiveWorkbook
Set Sheet2 = REVISIONCRNAUTO.Worksheets(2)
cell_value = Sheet2.Cells(4, "A").Value & Sheet2.Cells(4, "B").Value
If CheckBox1.Value = True And CheckBox4.Value = True And CheckBox7.Value = True And CheckBox2.Value = False And CheckBox3.Value = False _
And CheckBox6.Value = False And CheckBox5.Value = False And CheckBox8.Value = False And CheckBox9.Value = False And CheckBox10.Value = False And CheckBox11.Value = False And CheckBox12.Value = False _
And CheckBox13.Value = False And CheckBox14.Value = False And CheckBox15.Value = False Then
Sheet2.Activate
reponse = MsgBox("Êtes-vous sûr de vouloir générer ce RNC?", vbYesNo + vbQuestion, "Enregistrement RNC")
If reponse = vbYes Then
Sheets("Sheet2").Range("B4").Select
ActiveCell.EntireRow.Insert shift:=xlDown
Sheets("Sheet2").Range("B4:E4").Select
Selection.Borders.Weight = xlThin
Sheets("Sheet2").Range("B4").Select
ActiveCell.Value = "=b5+1"
Sheets("Sheet2").Range("A4").Select
Selection.Borders.Weight = xlThin
ActiveCell.Value = "E"
Else
Exit Sub
End If
End If
MsgBox ("Le nouveau RNC enregistré est le : " & cell_value)
You aren't changing the value of cell_value after you set it.
They are not linked forever like an Excel formula. You have to set it again once you change the cells that it is based on.
Put the cell_value = line right before the Else in addition to where it currently is.
I have "Filling form" worksheet where user is filling information and then I have "Print version" worksheet that is actually printing. I am making "CV tool" so user is filling his personal information and then my current VBA is saving end file from "Print version" to xls. and .pdf to the same folder with certain name both files where my "CV tool" is. Some people have experience of 10 years in 10 different work places and others have been only in 2 different companies previously. So before saving to .pdf and .xls my VBA hides rows that are empty to make end result look good.
The problem is that estetically it is not so good looking because some heading of work positions are at the end of the page and work description is continuing on the next page. Is there any way to make some kind of VBA to look for each page in "PrintArea" and if certain block is not fitting to this page VBA will insert "Page Break" before it to move it to the next page?
My current macro below (Sub doitallplease() is main command):
Sub Color()
Dim myRange As Range
Dim cell As Range
Set myRange = ThisWorkbook.Sheets("Print version").Range("Print_Area")
For Each cell In myRange
myRange.Interior.ColorIndex = 0
If cell.HasFormula = True And cell.value = "" And cell.EntireRow.Hidden = False Then Rows(cell.Row).EntireRow.Hidden = True
Next
End Sub
Sub MagicButton()
Dim iFileName$, iRow&, iCol&, iCell As Range, iArr
iFileName = ThisWorkbook.Path & "\CV_" & Sheets("Filling form").Range("F7") & "_" & Sheets("Filling form").Range("F9") & ".xls"
iArr = Array(1, 3, 4): iCol = UBound(iArr) + 1
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlManual
ThisWorkbook.Sheets("Print version").Copy
With ActiveWorkbook.ActiveSheet
.Buttons.Delete '.Shapes("Button 1").Delete
.UsedRange.value = .UsedRange.value
.SaveAs iFileName, xlExcel8: .Parent.Close
End With
Application.Calculation = xlAutomatic
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Sub exportpdfthisfile()
ActiveWorkbook.Sheets("Print version").Select
ActiveSheet.ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=ThisWorkbook.Path & "\CV_" & Sheets("Filling form").Range("F7") & "_" & Sheets("Filling form").Range("F9") & ".pdf", _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False
End Sub
Sub doitallplease()
Application.ScreenUpdating = False
ActiveWorkbook.Sheets("Print version").Visible = True
Call Color
Call MagicButton
Call exportpdfthisfile
ActiveWorkbook.Sheets("Filling form").Activate
ActiveWorkbook.Sheets("Print version").Visible = False
Application.ScreenUpdating = True
End Sub
I have a set of Excel spreadsheets to summarise. My sheets are numbered:
xxx-yy-zzzz; xxx-yy-zzz+1; etc.
I would like a reporting spreadsheet to retrieve information each time it is opened. I don't mind doing it with VBA or with formulae.
I've the macro below. I need to auto increment until it runs out of spreadsheets. All the files will be in the same folder, this file can be in any folder.
Sub Macro1()
'
' Macro1 Macro
' autopop
'
'
Range("C4").Select
ActiveCell.FormulaR1C1 = "='[413-05-001.xlsx]Cover'!R4C5"
Range("D4").Select
ActiveCell.FormulaR1C1 = "='[413-05-001.xlsx]Cover'!R5C3"
Range("E4").Select
ActiveCell.FormulaR1C1 = "='[413-05-001.xlsx]Order'!R27C9"
Range("F4").Select
ActiveCell.FormulaR1C1 = "='[413-05-001.xlsx]Cover'!R8C9"
End Sub
Siddharth's method above worked very well for when we were using very simple file names, but it got a lot harder when there were additions made to the filename... So i did some surfing and found a basis of a "list all files and put them in a worksheet" and using some of the code from Siddharth's answer above (thank you very much Mr. Siddharth) and the example i found online here http://alanmurray.blogspot.com/2013/08/excel-vba-list-all-excel-files-in-folder.html , i have finalised my code, and my little VBA app now does what i want - it opens a folder and goes through and pulls out particular cells and creates a summary report in seconds -> will save me hours of tedious work...
Code:
Sub ImportFileList()
Dim MyFolder As String 'Store the folder selected by the using
Dim FiletoList As String 'store the name of the file ready for listing
Dim NextRow As Long 'Store the row to write the filename to
On Error Resume Next
Application.ScreenUpdating = False
'Display the folder picker dialog box for user selection of directory
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Please select a folder"
.Show
.AllowMultiSelect = False
If .SelectedItems.Count = 0 Then
MsgBox "You did not select a folder"
Exit Sub
End If
MyFolder = .SelectedItems(1) & "\"
End With
'Dir finds the first Excel workbook in the folder
FiletoList = Dir(MyFolder & "*.xls")
Range("A1").Value = "Filename"
Range("B1").Value = "Purchase Order Number"
Range("C1").Value = "Vendor"
Range("D1").Value = "Date of PO"
Range("E1").Value = "Currency"
Range("F1").Value = "Subtotal"
Range("G1").Value = "VAT"
Range("H1").Value = "Total"
Range("A1:H1").Font.Bold = True
'Find the next empty row in the list
NextRow = Application.CountA(Range("A:A")) + 1
NextRow = NextRow + 1 ' skip a line
'Do whilst the dir function returns an Excel workbook
Do While FiletoList <> ""
Cells(NextRow, 1).Value = FiletoList 'Write the filename into the next available cell
Cells(NextRow, 2).Formula = "='[" & FiletoList & "]Cover'!R4C4" ' Cover is the excel sheet name
Cells(NextRow, 3).Formula = "='[" & FiletoList & "]Cover'!R6C3"
Cells(NextRow, 4).Formula = "='[" & FiletoList & "]Cover'!R4C7"
Cells(NextRow, 5).Formula = "='[" & FiletoList & "]Cover'!R21C4"
Cells(NextRow, 6).Formula = "='[" & FiletoList & "]Cover'!R19C5"
Cells(NextRow, 7).Formula = "='[" & FiletoList & "]Cover'!R20C5"
Cells(NextRow, 8).Formula = "='[" & FiletoList & "]Cover'!R21C5"
NextRow = NextRow + 1 'Move to next row
FiletoList = Dir 'Dir returns the next Excel workbook in the folder
Loop
Application.ScreenUpdating = True
End Sub
Is this what you are trying? (UNTESTED)
'~~> Change this to the directory which has .xlsx files
Const sDir = "C:\Temp\"
Sub Sample()
Dim ws As Worksheet
Dim i As Long, num As Long, Calcmode As Long
Dim FilesCount As Long, startNum As Long
On Error GoTo Whoa
Set ws = ThisWorkbook.Sheets("Sheet1")
With Application
.ScreenUpdating = False
Calcmode = .Calculation
.Calculation = xlCalculationManual
End With
'~~> Get the number of files in that directory
FilesCount = getFileCount(sDir)
startNum = 1
If FilesCount <> 0 Then
With ws
For i = 4 To (FilesCount + 3)
num = Format(startNum, "000")
.Range("C" & i).Formula = "='[413-05-" & num & ".xlsx]Cover'!R4C5"
.Range("D" & i).Formula = "='[413-05-" & num & ".xlsx]Cover'!R5C3"
.Range("E" & i).Formula = "='[413-05-" & num & ".xlsx]Order'!R27C9"
.Range("F" & i).Formula = "='[413-05-" & num & ".xlsx]Cover'!R8C9"
startNum = startNum + 1
Next i
End With
End If
LetsContinue:
With Application
.ScreenUpdating = True
.Calculation = Calcmode
End With
Exit Sub
Whoa:
MsgBox Err.Description
Resume LetsContinue
End Sub
Function getFileCount(s As String) As Long
Dim Path As String, Filename As String
Dim Count As Long
Path = s & "*.xlsx"
Filename = Dir(Path)
Do While Filename <> ""
Count = Count + 1
Filename = Dir()
Loop
getFileCount = Count
End Function