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
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 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
Need your help to get same objective to fill up the "null" value faster than below script .
Sub FillEmptyCell()
Dim rng As Range
Dim i As Long
Dim cell As Range
Dim sht As Worksheet
Set sht = ActiveWorkbook.Sheets("rawdata")
sht.Activate
Set rng = Range(Range("G2:G14614"), Range("G" & sht.UsedRange.Rows.Count))
For Each cell In rng
If cell.Value = "" Then cell.Value = "BLANKON"
Next
End Sub
Try,
Sub FillEmptyCell()
with workSheets("rawdata")
with .range(.cells(2, "G"), .cells(.rows.count, "G").end(xlup))
on error resume next
.specialcells(xlcelltypeblanks) = "BLANKON"
on error goto 0
end with
.Activate
end with
End Sub
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
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