This code takes 8 cells from a data entry form and copies those cells to the next empty row on another worksheet that is used as a database. It takes 15 seconds. It can speed up the code if it didn't copy to another sheet.
Is there a way to significantly speed up this code without merging the two sheets?
sub UpdateLogWorksheet1()
Application.ScreenUpdating = False
Application.EnableEvents = False
Dim historyWks As Worksheet
Dim inputWks As Worksheet
Dim nextRow As Long
Dim oCol As Long
Dim myRng As Range
Dim myCopy As String
Dim myclear As String
Dim myCell As Range
ActiveSheet.Unprotect "sallygary"
myCopy = "e4,g26,g16,g12,g18,g20,g22,g24"
Set inputWks = Worksheets("Dept 1 Input")
Set historyWks = Worksheets("1_Data")
With historyWks
nextRow = .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0).Row
End With
With inputWks
Set myRng = .Range(myCopy)
End With
With historyWks
With .Cells(nextRow, "A")
.Value = Now()
.NumberFormat = "mm/dd/yyyy"
End With
.Cells(nextRow, "B").Value = Application.UserName
oCol = 3
For Each myCell In myRng.Cells
historyWks.Cells(nextRow, oCol).Value = myCell.Value
oCol = oCol + 1
Next myCell
End With
With inputWks
On Error Resume Next
End With
On Error GoTo 0
ActiveSheet.Protect "sallygary"
Range("g12").Select
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
Don't copy cell by cell. Copy Entire tables with one operation. For example to copy a 100×3 table
Sheet2.Range("A2").Resize(100,3).Value2 = Sheet1.Range("G2").Resize(100,3).Value2
Related
Have a problem with my Excel table.
I have a smart table on sheet "Order calculation" and I would like to move this data to sheet "Sales History"
code below:
Option Explicit
Sub UpdateLogWorksheet()
Dim historyWks As Worksheet
Dim inputWks As Worksheet
Dim nextRow As Long
Dim oCol As Long
Dim myRng As Range
Dim myCopy As String
Dim myCell As Range
'cells to copy from Input sheet - some contain formulas
myCopy = ActiveSheet.ListObjects("Table1").DataBodyRange.Select
Set inputWks = Worksheets("Order calculation")
Set historyWks = Worksheets("Sales History")
With historyWks
nextRow = .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0).Row
End With
With historyWks
With .Cells(nextRow, "A")
.Value = Now
.NumberFormat = "mm/dd/yyyy hh:mm:ss"
End With
With inputWks
Set myRng = .Range(myCopy)
If Application.CountA(myRng) <> myRng.Cells.Count Then
MsgBox "Please fill in all the cells!"
Exit Sub
End If
End With
.Cells(nextRow, "B").Value = Application.UserName
oCol = 3
For Each myCell In myRng.Cells
historyWks.Cells(nextRow, oCol).Value = myCell.Value
oCol = oCol + 1
Next myCell
End With
'clear input cells that contain constants
With inputWks
On Error Resume Next
With .Range(myCopy).Cells.SpecialCells(xlCellTypeConstants)
.ClearContents
Application.GoTo .Cells(1) ', Scroll:=True
End With
On Error GoTo 0
End With
End Sub
If you just need to copy one sheet onto another, you can use the .Copy function of the Range object.
Sheets("Order calculation").Range("A1:AZ1000").Copy Destination:=Sheets("Sales History").Range("A1")
You will just need to decide what part of the source sheet to copy (A1:AZ1000) and where you want this copied to on the destination sheet (A1).
I was wondering if someone could help me with this excel VBA challenge i faced,
I am trying to delete a column if a column has only 0 and blank values, the format looks like the below picture:
As i have highlighted the two columns has only zero and blank values and those 2 columns should be deleted.
Excel Column Format
I have tried this code but unfortunately it deletes all the columns:
Sub dynamicRange()
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
Application.ScreenUpdating = False
Dim startCell As Range, lastRow As Long, lastCol As Long, ws As Worksheet
Set ws = ActiveSheet
Set startCell = Range("E9")
lastRow = ws.Cells(ws.Rows.Count, startCell.Column).End(xlUp).Row
lastCol = ws.Cells(startCell.Row, ws.Columns.Count).End(xlToLeft).Column
ws.Range(startCell, ws.Cells(lastRow, lastCol)).Select
Set a = Selection
For Each cell In a
If cell.Value = "Total" Or cell.Value = "Tag" Or cell.Value = "Delivery Fee" Or cell.Value = "CC/Cash" Or cell.Value = "Postcode" Then
cell.EntireColumn.Delete
End If
Next cell
For Each cell In a
If cell.Value = 0 Or cell.Value = "" Then
cell.EntireColumn.Delete
End If
Next cell
Application.Calculation = xlCalculationManual
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Looking forward for a solution, Thank you.
you can use count number of populated cells in range
WorksheetFunction.CountA(range)
This is sample code
sub test()
dim lasCol as integer
lastCol = Cells(1, Columns.Count).End(xlToLeft).Column
for i = lastCol to 1 Step - 1
if worksheetfunction.countA(Columns(i)) = 0 then
Columns(i).delete
end if
next i
end sub
Of course you can change Column to Range to check it content data or not that fit your file. eg
if worksheetfunction.countA(range("A2:A10, A15:A20")) = 0 then
Or
if worksheetfunction.countA(range(cells(2,i), cells(10,i))) + worksheetfunction.countA(range(cells(15,i), cells(20,i)))= 0 then
If you want to delete columns without value you can use Excel's own SUM() function with simple code as shown below.
Sub DynamicRange()
Dim startCell As Range
Dim SumRng As Range
Dim lastRow As Long, lastCol As Long
Dim C As Long
With Application
.EnableEvents = False
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With
With ActiveSheet
Set startCell = .Range("E9")
lastRow = .Cells(.Rows.Count, startCell.Column).End(xlUp).Row
lastCol = .Cells(startCell.Row, .Columns.Count).End(xlToLeft).Column
For C = lastCol To startCell.Column Step -1
Set SumRng = .Range(.Cells(startCell.Row, C), .Cells(lastRow, C))
If Application.Sum(SumRng) = 0 Then .Columns(C).Delete
Next C
End With
With Application
.EnableEvents = True
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
End Sub
I'm not sure I understand the significance of your startCell at E9 correctly. Your code doesn't appear to match with the picture of your worksheet in that respect. My code ignores values which are above row 9 but that would be very easy to modify. Just let me know. The point is that using the SUM() function makes the code run much faster than having to examine every cell.
Delete Zero-Blank Columns
Option Explicit
Sub DeleteEmptyColumns()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
Dim rng As Range, URng As Range, startCell As Range
Dim lastRow As Long, lastCol As Long, ws As Worksheet
Dim j As Long ' Column Counter
Dim i As Long ' Row Counter
On Error GoTo ProgramError
Set ws = ActiveSheet
Set startCell = ws.Range("E9")
lastRow = ws.Cells(ws.Rows.Count, startCell.Column).End(xlUp).Row
lastCol = ws.Cells(startCell.Row, ws.Columns.Count).End(xlToLeft).Column
For j = startCell.Column To lastCol
For i = startCell.Row To lastRow
Set rng = ws.Cells(i, j)
If rng.Value <> 0 And rng.Value <> "" Then Exit For
Next
If i > lastRow Then Set rng = ws.Cells(1, j): GoSub UnionRange
Next
' ' While developing such a code, use Hidden instead of Delete.
' If Not URng Is Nothing Then URng.EntireColumn.Hidden = True
If Not URng Is Nothing Then URng.EntireColumn.Delete
MsgBox "Operation finished successfully."
SafeExit:
Application.EnableEvents = True
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = True
Exit Sub
UnionRange:
If Not URng Is Nothing Then
Set URng = Union(URng, rng)
Else
Set URng = rng
End If
Return
ProgramError:
MsgBox "An unexpected error occurred."
On Error GoTo 0
GoTo SafeExit
End Sub
I need to save data from Excel form with multiple selection options to another excel sheet. As the user will press add record button these values will be added to another excel and the input excel will be cleared
Gaspcore is the input sheet and Gapdata is where the columns data will be saved.
Unable to debug this code line given below and code is mentioned below-
gapscore.Cells(nextRow, oCol).Value = myCell.Value
Sub AddGAP()
Dim gapscore As Worksheet
Dim gapdata As Worksheet
Dim nextRow As Long
Dim oCol As Long
Dim myRng As Range
Dim myCopy As String
Dim myCell As Range
'cells to copy from Gapscore Sheet - some contain formulas
myCopy = "G6:G161,N6:N161,O6:O161,Q6:Q161,R6:R161,S6:S161,T6:T161,U6:U161,V6:V161,X6:X161"
Set gapscore = Worksheets("Gap Analysis Score")
Set gapdata = Worksheets("GAPData")
With gapdata
nextRow = .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0).Row
End With
With gapscore
set myRng = .Range(myCopy)
End With
With gapdata
For Each myCell In myRng.Cells
gapscore.Cells(nextRow, oCol).Value = myCell.Value
oCol = oCol + 1
Next myCell
End With
'clear input cells that contain constants
With gapscore
On Error Resume Next
With .Range(myCopy).Cells.SpecialCells(xlCellTypeConstants)
.ClearContents
Application.GoTo .Cells(1) ', Scroll:=True
End With
On Error GoTo 0
End With
End Sub
With this code, specified cells are copied into a database worksheet and then clears the data form for the next entry. How can I modify the code so that one (or perhaps more than one) cell is not cleared?
Option Explicit
Sub UpdateLogWorksheet()
Dim historyWks As Worksheet
Dim inputWks As Worksheet
Dim nextRow As Long
Dim oCol As Long
Dim myRng As Range
Dim myCopy As String
Dim myCell As Range
ActiveSheet.Unprotect "sallygary"
'cells to copy from Input sheet - some contain formulas
myCopy = "g12,g14,g18,g20,g22,g24,i16,i18,i20,i22,i24,k16,k18,k20,k22,k24,m16,m18,m20,m22,m24,o16,o18,o20,o22,o24,q16,q18,q20,q22,q24,s16,s18,s20,s22,s24,u16,u18,u20,u22,u24"
Set inputWks = Worksheets("Input")
Set historyWks = Worksheets("1_Data")
With historyWks
nextRow = .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0).Row
End With
With inputWks
Set myRng = .Range(myCopy)
'If Application.CountA(myRng) <> myRng.Cells.Count Then
' MsgBox "Please fill in all the cells!"
' Exit Sub
'End If
End With
With historyWks
With .Cells(nextRow, "A")
.Value = "e4"
.NumberFormat = "mm/dd/yyyy" 'hh:mm:ss
End With
.Cells(nextRow, "B").Value = Application.UserName
oCol = 3
For Each myCell In myRng.Cells
historyWks.Cells(nextRow, oCol).Value = myCell.Value
oCol = oCol + 1
Next myCell
End With
'clear input cells that contain constants
With inputWks
On Error Resume Next
With .Range(myCopy).Cells.SpecialCells(xlCellTypeConstants)
.ClearContents
Application.GoTo .Cells(1) ', Scroll:=True
End With
On Error GoTo 0
End With
ActiveSheet.Protect "sallygary"
Range("g12").Select
End Sub
Add another string variable similar to the myCopy var.
dim myCopy as string, myClear as string
'cells to copy from Input sheet - some contain formulas
myCopy = "g12,g14,g18,g20,g22,g24,i16,i18,i20,i22,i24,k16,k18,k20,k22,k24,m16,m18,m20,m22,m24,o16,o18,o20,o22,o24,q16,q18,q20,q22,q24,s16,s18,s20,s22,s24,u16,u18,u20,u22,u24"
'cells to CLEAR from Input sheet
myClear = "g12,g18,g22,i16,i20,i24,k18,k22,m16,m20,m24,o18,o22,q16,q20,q24,s18,s22,u16,u20,u24"
Now use that range definition to clear the cell contents.
With .Range(myClear).Cells.SpecialCells(xlCellTypeConstants)
.ClearContents
Application.GoTo .Cells(1) ', Scroll:=True
End With
Good day to all !!
I manage a contact center and require the staff to capture some data to calculate their productivity
This could've been done easily through ACCESS forms, but the team is not allowed to have ACCESS due to some policies
I wanted to know if i am to create a few predefined fields in excel for data entry (Dropdowns and some free text), where the agents enter the information each time, then click a "Submit" button.
Once the "Submit" button is clicked, the data is then passed into an ACCESS table, and the excel fields are reset to blank.
Note: Each agent has an excel file with their name stored on our shared drive. The ACCESS is also stored on the shared drive. Paths are predefined and fixed.
Can anyone please help with this
I'm sure this has been posted somewhere before, but I cant seem to find the exact requirements.
Thanks
That should work. Copy, paste and adjust workbook name.
Option Explicit
Sub UpdateLogWorksheet()
Dim historyWks As Worksheet
Dim inputWks As Worksheet
Dim wb1 As Worksheet
Dim nextRow As Long
Dim oCol As Long
Dim myRng As Range
Dim myCopy As String
Dim myCell As Range
'cells to copy from Input sheet - some contain formulas
myCopy = "D5,D7,D9,D11,D13"
Set inputWks = Worksheets("Input")
Set historyWks = Worksheets("PartsData")
Set wb1 = Workbooks("1.xls").Worksheets("PartsData") 'change Workbook
With inputWks
Set myRng = .Range(myCopy)
If Application.CountA(myRng) <> myRng.Cells.Count Then
MsgBox "Please fill in all the cells!"
Exit Sub
End If
End With
With wb1
nextRow = .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0).Row
With .Cells(nextRow, "A")
.Value = Now
.NumberFormat = "mm/dd/yyyy hh:mm:ss"
End With
.Cells(nextRow, "B").Value = Application.UserName
oCol = 3
For Each myCell In myRng.Cells
.Cells(nextRow, oCol).Value = myCell.Value
oCol = oCol + 1
Next myCell
End With
'clear input cells that contain constants
With inputWks
On Error Resume Next
With .Range(myCopy).Cells.SpecialCells(xlCellTypeConstants)
.ClearContents
Application.GoTo .Cells(1) ', Scroll:=True
End With
On Error GoTo 0
End With
End Sub
Edit:
Option Explicit
Sub UpdateLogWorksheet()
Application.ScreenUpdating = False
Dim historyWks As Worksheet
Dim inputWks As Worksheet
Dim wb1 As Worksheet
Dim nextRow As Long
Dim oCol As Long
Dim wb_path As String
Dim myCopy As String
Dim wb_name As String
Dim myRng As Range
Dim myCell As Range
'cells to copy from Input sheet - some contain formulas
myCopy = "D5,D7,D9,D11,D13"
wb_name = "1.xls" '2nd workbook name
wb_path = "C:\Reports\" & wb_name '2nd workbook path on HDD
Set inputWks = ThisWorkbook.Worksheets("Input") 'form sheet
Set historyWks = ThisWorkbook.Worksheets("PartsData") 'data in form sheet
Set myRng = inputWks.Range(myCopy)
If Application.CountA(myRng) <> myRng.Cells.Count Then
MsgBox "Please fill in all the cells!"
Exit Sub
End If
'if 2nd workbook file does not exists, message will pop up
If Dir(wb_path) = "" Then
MsgBox ("File does not exists")
Exit Sub:
'if exists it will open and become invisible
Else
Workbooks.Open Filename:=wb_path
Application.Windows(wb_name).Visible = False
Set wb1 = Workbooks(wb_name).Worksheets("PartsData") 'data in 2nd workbook
'copy data to 2nd workbook
With wb1
nextRow = .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0).Row
With .Cells(nextRow, "A")
.Value = Now
.NumberFormat = "mm/dd/yyyy hh:mm:ss"
End With
.Cells(nextRow, "B").Value = Application.UserName
oCol = 3
For Each myCell In myRng.Cells
.Cells(nextRow, oCol).Value = myCell.Value
oCol = oCol + 1
Next myCell
End With
Application.Windows(wb_name).Visible = True
Workbooks(wb_name).Close True
End If
'copy data to form sheet
With historyWks
nextRow = .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0).Row
With .Cells(nextRow, "A")
.Value = Now
.NumberFormat = "mm/dd/yyyy hh:mm:ss"
End With
.Cells(nextRow, "B").Value = Application.UserName
oCol = 3
For Each myCell In myRng.Cells
.Cells(nextRow, oCol).Value = myCell.Value
oCol = oCol + 1
Next myCell
End With
'clear input cells that contain constants
With inputWks
On Error Resume Next
With .Range(myCopy).Cells.SpecialCells(xlCellTypeConstants)
.ClearContents
Application.GoTo .Cells(1) ', Scroll:=True
End With
On Error GoTo 0
End With
Application.ScreenUpdating = True
End Sub