I'm building a weekly time-sheet tracking database. The input form contains 2 list boxes. "ListBox1" and "ListBox2" . ListBox1 allows the user to select a specific project, once a project is selected - various text boxes are populated with information. The user can then input their daily hours worked. When the user clicks a submit button the code verify's if there is a worksheet allocated for the selected project - if yes - it will load the inputted data into the sheet, if no it will create a new sheet. Once data is entered it will calculate and autosend a notification email if certain criteria are met.
At this point - ListBox 2 updates with the contents of all the inputted entries for that given project worksheet when the "Submit" button is clicked.
I would rather for ListBox 2 to update as the user selects the project from ListBox 1. I've tried moving the related code to the Listbox1_Click() routine but to no avail.
I'm very new to this so any suggestions would be greatly appreciated.
Working code as it currently stands.
Private Sub CommandButton1_Click()
'activateSheet(Weeklyhours As String)
'Sheets(Weeklyhours).Select
'ActiveSheet.Range("I2").Select = TxtMonhours.Text
'ActiveSheet.Range("j2").Select = TxtTueshours.Text
Dim Total As Double
Dim i As Integer
Dim PO As String
Dim CoRequest As Integer
'Make sure correct worksheet is selected to store data
'Application.Workbooks("TestDataBase.xlsx")
'Add a sheet for the PO Number
PO_Sheet_Name = txtPO.Text
CoRequest = txtPOhours.Value * 0.2
MsgBox "Safety hours level = " & CoRequest
Safetyhrs.Text = "FYI - Hours Warnings will commence below " & CoRequest & " hours."
'Check to see if a sheet already exists
For rep = 1 To (Worksheets.Count)
If LCase(Sheets(rep).Name) = LCase(PO_Sheet_Name) Then 'If a sheet exists activate it and confirm hours are available
Sheets(PO_Sheet_Name).Activate
'Confirm hours left.
MsgBox "Hrs available = " & txthrsavail.Value
If txthrsavail.Value <> "0" Or txthrsavail.Value < "0" Then
'Find last row
LastRow = Worksheets(PO_Sheet_Name).Cells(65000, 9).End(xlUp).Row
FirstRow = Worksheets(PO_Sheet_Name).Cells(2, 9).Row
i = LastRow + 1
'MsgBox LastRow
Cells(LastRow + 1, 8).Value = txtPO.Text
Cells(LastRow + 1, 9).Value = txtweek.Text
Cells(LastRow + 1, 10).Value = TxtMonhours.Text
Cells(LastRow + 1, 11).Value = TxtTuehours.Text
Cells(LastRow + 1, 12).Value = TxtWedhours.Text
Cells(LastRow + 1, 13).Value = TxtThurhours.Text
Cells(LastRow + 1, 14).Value = Txtfrihours.Text
Cells(LastRow + 1, 15).Value = txtSathrs.Text
Cells(LastRow + 1, 16).Value = txtSunhrs.Text
'Add total hours for week
Cells(LastRow + 1, 18).Activate
ActiveCell.FormulaR1C1 = "=SUM(RC[-8]:RC[-2])"
'Calculate total hours todate
Total = Application.sum(Sheets(PO_Sheet_Name).Range("r3:r" & i))
MsgBox "Total hours consumed = " & Total & "Hrs."
txtweektotal.Text = Cells(LastRow + 1, 18)
txthoursused.Text = Total
txthrsavail.Text = txtPOhours.Value - Total
Cells(LastRow + 1, 20).Value = txthrsavail.Text
' Upade table
With Me.ListBox2
.ColumnCount = 14
.ColumnWidths = "70;55;55;55;55;55;55;55;55;20;45;10;55;55"
.RowSource = Sheets(PO_Sheet_Name).Range("h2:t" & i).Address
End With
'Issue Status Check
If txthrsavail.Value < CoRequest And txthrsavail.Value > "0" Or txthrsavail.Value = CoRequest And txthrsavail.Value > "0" Then
MsgBox "There are only " & txthrsavail.Value & " hours remaining plesase notify your supervisor"
Call Mail_ActiveSheet
ElseIf txthrsavail.Value = "0" Or txthrsavail.Value < "0" Then
MsgBox "No Hours are available on this PO - please speak to your manager and stop all work", vbCritical
End If
End If
Exit Sub
End If
Next 'If no sheet exists - create a sheet that matches the PO number
Sheets.Add After:=Sheets(Sheets.Count)
Sheets(ActiveSheet.Name).Name = PO_Sheet_Name
MsgBox "Creating PO Sheet as it does not Exist"
'Enter Header Lines for spreadsheet
Range("H2").Select
ActiveCell.FormulaR1C1 = "PO Number"
Range("I2").Select
ActiveCell.FormulaR1C1 = "Weekend"
Range("J2").Select
ActiveCell.FormulaR1C1 = "Monday"
Range("K2").Select
ActiveCell.FormulaR1C1 = "Tuesday "
Range("L2").Select
ActiveCell.FormulaR1C1 = "Wednesday "
Range("M2").Select
ActiveCell.FormulaR1C1 = "Thursday "
Range("N2").Select
ActiveCell.FormulaR1C1 = "Friday"
Range("O2").Select
ActiveCell.FormulaR1C1 = "Sathurday "
Range("P2").Select
ActiveCell.FormulaR1C1 = "Sunday"
Range("R2").Select
ActiveCell.FormulaR1C1 = "Total"
Range("T2").Select
ActiveCell.FormulaR1C1 = "Hours Remaining"
'Enter Data
'Find last row
LastRow = Worksheets(PO_Sheet_Name).Cells(65000, 9).End(xlUp).Row
FirstRow = Worksheets(PO_Sheet_Name).Cells(2, 9).Row
i = LastRow + 1
'MsgBox LastRow
'Enter data to rows
Cells(LastRow + 1, 8).Value = txtPO.Text
Cells(LastRow + 1, 9).Value = txtweek.Text
Cells(LastRow + 1, 10).Value = TxtMonhours.Text
Cells(LastRow + 1, 11).Value = TxtTuehours.Text
Cells(LastRow + 1, 12).Value = TxtWedhours.Text
Cells(LastRow + 1, 13).Value = TxtThurhours.Text
Cells(LastRow + 1, 14).Value = Txtfrihours.Text
Cells(LastRow + 1, 15).Value = txtSathrs.Text
Cells(LastRow + 1, 16).Value = txtSunhrs.Text
' 'Add total hours for week
Cells(LastRow + 1, 18).Activate
ActiveCell.FormulaR1C1 = "=SUM(RC[-8]:RC[-2])"
'Calculate total hours todate
Total = Application.sum(Sheets(PO_Sheet_Name).Range("r3:r" & i))
txtweektotal.Text = Cells(LastRow + 1, 18)
txthoursused.Text = Total
txthrsavail.Text = txtPOhours.Value - Total
Cells(LastRow + 1, 20).Value = txthrsavail.Text
'issue status check
If txthrsavail.Value < CoRequest And txthrsavail.Value > "0" Then
MsgBox "There are only " & txthrsavail.Value & "available plesase notify your supervisor"
'send mail update
Call Mail_ActiveSheet
ElseIf txthrsavail.Value = "0" Or txthrsavail.Value < "0" Then
MsgBox "You have no hours left on PO - Please contact your manager and stop all work", vbCritical
End If
'Load history
With Me.ListBox2
.ColumnCount = 14
.ColumnWidths = "70;55;55;55;55;55;55;55;55;20;45;10;55;55"
.RowSource = Sheets(PO_Sheet_Name).Range("h2:t" & i).Address
End With
ActiveWorkbook.Save
End Sub
ListBox1 Code as it currently stands. [ I've commented out where I was placing Me.ListBox2 command as it won't run correctly.]
Private Sub ListBox1_Click()
Dim Total As Long
Dim i As Integer
Dim PO As String
Dim CoRequest As Integer
PO_Sheet_Name = txtPO.Text
Sheets("Projects Sheet").Range("k3").Value = ListBox1.Value
txtsponsor.Text = Sheets("Projects Sheet").Range("L3")
txtPOhours.Text = Sheets("Projects Sheet").Range("M3")
txtPO.Text = Sheets("Projects Sheet").Range("N3")
'Find last row
' LastRow = Worksheets(PO_Sheet_Name).Cells(65000, 9).End(xlUp).Row
'FirstRow = Worksheets(PO_Sheet_Name).Cells(2, 9).Row
' i = LastRow + 1
' With Me.ListBox2
' .ColumnCount = 14
' .ColumnWidths = "70;55;55;55;55;55;55;55;55;20;45;10;55;55"
' .RowSource = Sheets(PO_Sheet_Name).Range("h2:r" & i).Address
' End With
You should use ListBox1_Change or ListBox1_BeforeUpdate
Here is a screenshot of MicroSoft VBA, you can use the two dropdown lists on top to select an object and an associated event :
and yet the Private Sub ListBox1_Click() is existing so I don't know what was your problem with
Related
I'm new to InkPicture but I like to use it for user to put signature into the form.
I can't seem to save the signature (inkpicture) to the spreadsheet it just inputs it as 0 into the cell I specify.
With UserForm1.InkPicture1.InkEnabled = False Set.Ink
Me.InkPicture1.Ink
.InkEnabled = True End With
lrDep = Sheets("Deploy").Range("A" & Rows.Count).End(xlUp).Row Sheets("Deploy").Cells(lrDep + 1, "A").Value = TBox1.Text Sheets("Deploy").Cells(lrDep + 1, "B").Value = TBox2.Text Sheets("Deploy").Cells(lrDep + 1, "C").Value = TBox3.Text Sheets("Deploy").Cells(lrDep + 1, "D").Value = TBox4.Text
Sheets("Deploy").Cells(lrDep + 1, "G").Value = InkPicture1.Ink
Could someone please help me.
Thank you.
This is not a complete answer but will help you on your way, comment if you have any questions.
First you will have to have a text box on your form that requires the asset ID,
this will have to be amended to match your current form.
Dim RowN As Long
Dim SearchTxt
SearchTxt = TextBox1.Value 'This should be set to the text box name on the form of the asset ID
On Error Resume Next
RowN = Application.WorksheetFunction.Match(SearchTxt, Range("A:A"), 0)
On Error GoTo 0
If RowN > 0 Then
'your code here if matches
MsgBox RowN ' display the row number
Else
'your code here if no match, possibly add new row of data
MsgBox "No match found"
End If
Now you can amend each line of code to use the found row number, for example:
Sheets("Data").Cells("A" & RowN).Value = TextBox1.Txt
If I was creating this form, I would add a search button to check the asset ID and where it finds a match, all the text boxes would then be populated with the current values of the data, these can then be amended before adding back to the sheet.
The following will look for the ID in Column A and if found will use that row to enter the data, this assumes that the ID is stored in TextBox1.Text, amend as required:
Private Sub SB1_Click()
Dim lrREG As Long, lrB As Long, lrDep As Long, lrDis As Long, lrDAT As Long
Dim foundID As Range
Set foundID = Sheets("Data").Range("A:A").Find(What:=TextBox1.Text, Lookat:=xlWhole)
If Not foundID Is Nothing Then
Sheets("Data").Cells(foundID.Row, "A").Value = TextBox1.Text
Sheets("Data").Cells(foundID.Row, "B").Value = TextBox2.Text
Sheets("Data").Cells(foundID.Row, "C").Value = TextBox3.Text
Else
lrDAT = Sheets("Data").Range("A" & Rows.Count).End(xlUp).Row + 1
Sheets("Data").Cells(lrDAT, "A").Value = TextBox1.Text
Sheets("Data").Cells(lrDAT, "B").Value = TextBox2.Text
Sheets("Data").Cells(lrDAT, "C").Value = TextBox3.Text
End If
lrREG = Sheets("Register").Range("A" & Rows.Count).End(xlUp).Row
Sheets("Register").Cells(lrREG + 1, "A").Value = TextBox1.Text
Sheets("Register").Cells(lrREG + 1, "B").Value = TextBox2.Text
Sheets("Register").Cells(lrREG + 1, "C").Value = TextBox3.Text
lrB = Sheets("Built").Range("A" & Rows.Count).End(xlUp).Row
Sheets("Built").Cells(lrB + 1, "A").Value = TB1.Text
Sheets("Built").Cells(lrB + 1, "B").Value = TB2.Text
Sheets("Built").Cells(lrB + 1, "C").Value = TB3.Text
Sheets("Built").Cells(lrB + 1, "D").Value = TB4.Text
Sheets("Built").Cells(lrB + 1, "E").Value = TB5.Text
Sheets("Built").Cells(lrB + 1, "F").Value = TB6.Text
lrDep = Sheets("Deploy").Range("A" & Rows.Count).End(xlUp).Row
Sheets("Deploy").Cells(lrDep + 1, "A").Value = TBox1.Text
Sheets("Deploy").Cells(lrDep + 1, "B").Value = TBox2.Text
Sheets("Deploy").Cells(lrDep + 1, "C").Value = TBox3.Text
Sheets("Deploy").Cells(lrDep + 1, "D").Value = TBox4.Text
Sheets("Deploy").Cells(lrDep + 1, "E").Value = TBox5.Text
Sheets("Deploy").Cells(lrDep + 1, "F").Value = TBox6.Text
lrDis = Sheets("Dispose").Range("A" & Rows.Count).End(xlUp).Row
Sheets("Dispose").Cells(lrB + 1, "A").Value = TextBo1.Text
Sheets("Dispose").Cells(lrDis + 1, "B").Value = TextBo2.Text
Sheets("Dispose").Cells(lrDis + 1, "C").Value = TextBo3.Text
Sheets("Dispose").Cells(lrDis + 1, "D").Value = TextBo4.Text
Sheets("Dispose").Cells(lrDis + 1, "E").Value = TextBo5.Text
Sheets("Dispose").Cells(lrDis + 1, "F").Value = TextBo6.Text
End Sub
I am new to VBA, and I am working on a userform, which was created by someone else. The userform has four areas(Cost Code1, Cost Code 2, exc...) that input information(Cost Code, Truck Rent, Regular Hours and Overtime Hours) into specific columns on the worksheet. Right now there are text boxes at the top of the form that enters the employee name, job number and date with all of the information.
The new project has two job numbers, so instead of using the Job Number Text Box at the top, I need to add Option Buttons, or Check Boxes (whichever is easier) to choose between the two different job numbers for the four groups of information. I would like to only be allowed to select one job number per area on the userform. The job numbers will be located on a second tab called Employees in cells H1 and K1. I need the job number to be entered in column number 4. What is the code for the Check Boxes, or Option Buttons, and where would I enter it in the original code? I appreciate any help.
Private Sub cbOK_Click()
Dim NextRow As Long
'Variable for cycling through cell input
Dim i As Long
Dim Userdate As Date
i = 1
Set EESheet = ActiveWorkbook.Sheets("Employees")
Set TLISheet = ActiveWorkbook.Sheets("Worksheet")
'Activate Worksheet Tab
Sheets("Worksheet").Activate
'Set Autocalc off to speed things up.
Application.Calculation = xlCalculationManual
'Error Handling, go to bad.
On Error GoTo Bad
Userdate = tbDate.Value
'Transfer the data to the rows
For i = 1 To 6
NextRow = Application.WorksheetFunction.CountA(Range("A:A")) + 1
If Me.Controls("tbCC" & i & "RegHrs").Value <> "" Then
Cells(NextRow, 1) = tbDate.Value
Cells(NextRow, 2) = cmbEmployeeName.Value
Cells(NextRow, 3) = Application.WorksheetFunction.VLookup(cmbEmployeeName.Value, EESheet.Range("A:B"), 2, False)
Cells(NextRow, 4) = tbJobNumber.Value
Cells(NextRow, 5) = Me.Controls("tbJobExtra" & i).Value
Cells(NextRow, 6) = Me.Controls("cmbCC" & i).Value
Cells(NextRow, 7) = Application.WorksheetFunction.VLookup(cmbEmployeeName.Value, EESheet.Range("A:C"), 3, False)
Cells(NextRow, 8) = Application.WorksheetFunction.VLookup(cmbEmployeeName.Value, EESheet.Range("A:D"), 4, False)
Cells(NextRow, 10) = Application.WorksheetFunction.VLookup(cmbEmployeeName.Value, EESheet.Range("A:E"), 5, False)
If EEtype = 1 Then
Cells(NextRow, 9) = "SOH"
Else
Cells(NextRow, 9) = "REG"
End If
Cells(NextRow, 10) = Me.Controls("tbCC" & i & "RegHrs").Value
End If
If Me.Controls("tbCC" & i & "OTHrs").Text <> "" Then
NextRow = Application.WorksheetFunction.CountA(Range("A:A")) + 1
Cells(NextRow, 1) = tbDate.Value
Cells(NextRow, 2) = cmbEmployeeName.Value
Cells(NextRow, 3) = Application.WorksheetFunction.VLookup(cmbEmployeeName.Value, EESheet.Range("A:B"), 2, False)
Cells(NextRow, 4) = tbJobNumber.Value
Cells(NextRow, 5) = Me.Controls("tbJobExtra" & i).Value
Cells(NextRow, 6) = Me.Controls("cmbCC" & i).Value
Cells(NextRow, 7) = Application.WorksheetFunction.VLookup(cmbEmployeeName.Value, EESheet.Range("A:C"), 3, False)
Cells(NextRow, 8) = Application.WorksheetFunction.VLookup(cmbEmployeeName.Value, EESheet.Range("A:D"), 4, False)
Cells(NextRow, 9) = "OVT"
Cells(NextRow, 10) = Me.Controls("tbCC" & i & "OTHrs").Value
End If
If i + 1 = 7 Then Exit For
If Me.Controls("cmbCC" & i + 1).Value = "" Then Exit For
Next
Bad:
If Err.Number = 1004 Then
MsgBox "This EE Does Not Exist or You Typed Their Name Incorrectly. Check the EE name spelling or enter the EE into the Employees Tab."
NextRow = Application.WorksheetFunction.CountA(Range("A:A"))
Rows(NextRow).Delete
EEpayrollentry.Hide
Sheets("Employees").Activate
End If
i = 1
For i = 1 To 6
cmbEmployeeName.Value = ""
Me.Controls("tbJobExtra" & i).Text = ""
Me.Controls("cmbCC" & i).Text = ""
Me.Controls("tbCC" & i & "RegHrs").Text = ""
Me.Controls("tbCC" & i & "OTHrs").Text = ""
Next
EEpayrollentry.lbTotalHours.Caption = 0
End Sub
I'm exporting my data from MS Project to MS Excel (single pre-defined file with a given name all the time, for e.g. XYZ.xlsx) and want to have different worksheet in the excel for every workstream in the project. And number of workstreams can increase in future, thus I've to keep it dynamic.
As of now my code does the export, but I also want it to check if the workstream already exists,
- if yes, delete all the data in that worksheet and paste the new data in XYZ file.
- if no, create a new worksheet in the XYZ file and paste the data into it.
Can anyone please help as I'm on a deadline to finish it.
Code that I'm using it,
Set tsks = ThisProject.Tasks
For Each t In tsks
If Not t Is Nothing Then
If t.OutlineLevel > 1 Then
If t.OutlineLevel = 2 Then
If ExcelRowCounter > 2 Then
'Finish formatting the sheet we just finished
For i = 1 To 7
xlSheet.Columns(i).AutoFit
Next i
End If
'Add Excel sheet, name it and define column headers
AppActivate ExcelAppTitle
Set xlSheet = xlBook.Worksheets.Add
ExcelSheetName = Left(Replace(t.Name, "&", "and"), 30)
xlSheet.Name = ExcelSheetName
xlSheet.Cells(1, 1).Value = "Task Name"
xlSheet.Cells(1, 2).Value = "Duration (days)"
xlSheet.Cells(1, 3).Value = "Start Date"
xlSheet.Cells(1, 4).Value = "Finish Date"
xlSheet.Cells(1, 5).Value = "Workstream Group"
xlSheet.Cells(1, 6).Value = "% Complete"
xlSheet.Cells(1, 7).Value = "Status"
xlSheet.Range(xlSheet.Cells(1, 1), xlSheet.Cells(1, 7)).Font.Bold = True
ExcelRowCounter = 2
End If
xlSheet.Cells(ExcelRowCounter, 1).Value = t.Name
xlSheet.Cells(ExcelRowCounter, 2).Value = t.Duration / (8 * 60)
xlSheet.Cells(ExcelRowCounter, 3).Value = Format(t.Start, "mm/dd/yyyy")
xlSheet.Cells(ExcelRowCounter, 4).Value = Format(t.Finish, "mm/dd/yyyy")
xlSheet.Cells(ExcelRowCounter, 5).Value = t.Text1
xlSheet.Cells(ExcelRowCounter, 6).Value = t.PercentComplete
xlSheet.Cells(ExcelRowCounter, 7).Value = t.Number1
xlSheet.Cells(ExcelRowCounter, 1).IndentLevel = 2 * (t.OutlineLevel - 2)
If t.Summary = "True" Then
xlSheet.Range(xlSheet.Cells(ExcelRowCounter, 1), xlSheet.Cells(ExcelRowCounter, 6)).Font.Bold = True
End If
ExcelRowCounter = ExcelRowCounter + 1
End If
End If
Next t
For i = 1 To 7
xlSheet.Columns(i).AutoFit
Next i
Here's as simple method:
Function AddOrGetWorksheet(withName As String) As Worksheet
Dim found As Boolean
found = False
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Sheets
If (LCase(ws.Name) = LCase(withName)) Then
found = True
Set AddOrGetWorksheet = ws
Exit For
End If
Next
If (Not found) Then
Set AddOrGetWorksheet = ActiveWorkbook.Sheets.Add()
AddOrGetWorksheet.Name = withName
End If
End Function
So I have 4 sheets that are called "old", "current", "input", and "buttons". The process is to: press a button on the "buttons" sheet to clear the "current" sheet and "input" sheet, paste data onto the "input" sheet and press a macro button on the "buttons" sheet to populate the "current" sheet. Most of the macro will be formatting the "current" sheet and using index match for data from the "old" sheet. What I'm trying to do is add a step in the beginning to clear the "old" sheet and then copy and paste the data from the "current" sheet onto the "old" sheet. The reason is that I will be using this weekly and every time I run the macro, I want the "current" sheet, that was created last time I ran the macro, to move to the "old" sheet. This is currently the code that I have...
Sub Load16()
Application.ScreenUpdating = False
'Define Workbooks
Dim loopCount As Integer
Dim loopEnd As Integer
Dim writeCol As Integer
Dim matchRow As Integer
Dim writeRow As Integer
Dim writeEnd As Integer
loopEnd = WorksheetFunction.CountA(Worksheets("Input").Range("A:A"))
writeEnd = WorksheetFunction.CountIf(Worksheets("Input").Range("L:L"), "-1")
loopCount = 1
writeRow = 1
Worksheets("Buttons").Range("F17:I17").Copy
Worksheets("Current").Range("J2:M" & writeEnd).PasteSpecial Paste:=xlPasteAll
Application.CutCopyMode = False
Do While loopCount <= loopEnd
If Worksheets("Input").Cells(loopCount, 12).Value <> "" And
Worksheets("Input").Cells(loopCount, 12).Value <> 0 Then
Worksheets("Current").Cells(writeRow, 1).Value = Worksheets("Input").Cells(loopCount, 26).Value
writeCol = 2
Do While writeCol <= 9
Worksheets("Current").Cells(writeRow, writeCol).Value = Worksheets("Input").Cells(loopCount, writeCol - 1)
writeCol = writeCol + 1
Loop
writeCol = 14
Do While writeCol <= 30
Worksheets("Current").Cells(writeRow, writeCol).Value = Worksheets("Input").Cells(loopCount, writeCol - 5)
writeCol = writeCol + 1
Loop
Worksheets("Current").Cells(writeRow, 31).Value = Worksheets("Input").Cells(loopCount, 27)
writeRow = writeRow + 1
Else
End If
loopCount = loopCount + 1
Loop
Worksheets("Current").Range("J1").Value = "Counsel"
Worksheets("Current").Range("K1").Value = "Background"
Worksheets("Current").Range("L1").Value = "Comments"
Worksheets("Current").Range("M1").Value = "BM Action"
Lookup Data for K - M and a few other things
loopCount = 2
Do While loopCount <= loopEnd
matchRow = 0
On Error Resume Next
matchRow = WorksheetFunction.Match(Worksheets("Current").Cells(loopCount, 1).Value, _
Worksheets("Old").Range("A:A"), 0)
If matchRow = 0 Then
Else
Worksheets("Current").Cells(loopCount, 11).Value = Worksheets("Old").Cells(matchRow, 11).Value
Worksheets("Current").Cells(loopCount, 12).Value = Worksheets("Old").Cells(matchRow, 12).Value
Worksheets("Current").Cells(loopCount, 13).Value = Worksheets("Old").Cells(matchRow, 13).Value
End If
Worksheets("Current").Cells(loopCount, 10).Value =
Worksheets("Current").Cells(loopCount, 18).Value
loopCount = loopCount + 1
Loop
Sheets("Current").Range("A2:AE" & loopEnd).Sort Key1:=Sheets("Current").Range("H2"), _
Order1:=xlAscending, Header:=xlNo
Worksheets("Current").Columns("A:BZ").AutoFit
Application.ScreenUpdating = True
Worksheets("Buttons").Select
MsgBox loopEnd - 1 & " Rows processed. " & writeEnd & " Rows remain."
End Sub
Thanks guys.
A small function like this should do the trick.
Sub copy_current_data()
'Select Old Sheet
Sheets("Old").Select
'Clear all cells from Old Sheet
Sheets("Old").Cells.ClearContents
'Copy Cells from Current Sheet
Sheets("Current").Cells.Copy
'Select "A1" in old sheet
Sheets("Old").Range("A1").Select
'Paste Data
ActiveSheet.Paste
End Sub
I was running a VBA code in Excel 2007. I got the above mention run/Application error of 1004.
My code is
Public Sub LblImport_Click()
Dim i As Long, j As Long
Dim vData As Variant, vCleanData As Variant, vFile As Variant, sMarket As String
Dim wbkExtract As Workbook, sLastCellAddress As String, month As String
Dim cnCountries As New Collection
Application.ScreenUpdating = False
' Get the name of the Dataview Extract file to transform and the market name
vFile = "D:\DRX\" & "Norvasc_Formatted.xlsx"
sMarket = "Hypertension"
ThisWorkbook.Worksheets("Control").Range("TherapeuticMarket").Value = "Hypertension"
' Clear all existing data from this workbook
ThisWorkbook.Worksheets("RawData").Cells.ClearContents
' Create labels in Raw Data Sheet
ThisWorkbook.Worksheets("RawData").Cells(1, 1).Value = "Therapy Market"
ThisWorkbook.Worksheets("RawData").Cells(1, 2).Value = "Country"
ThisWorkbook.Worksheets("RawData").Cells(1, 3).Value = "Brand"
ThisWorkbook.Worksheets("RawData").Cells(1, 4).Value = "Corporation"
ThisWorkbook.Worksheets("RawData").Cells(1, 5).Value = "Molecule"
' Open Dataview extract, copy and clean data
Set wbkExtract = Workbooks.Open(vFile)
i = 2
Do While wbkExtract.ActiveSheet.Cells(1, i).Value <> ""
If UCase(Mid(wbkExtract.ActiveSheet.Cells(1, i).Value, 1, 3)) = "TRX" Then
month = Split(wbkExtract.ActiveSheet.Cells(1, i).Value, "/")(1)
If Len(month) = 1 Then
month = "0" + month
End If
ThisWorkbook.Worksheets("RawData").Cells(1, i + 4).Value = Mid(wbkExtract.ActiveSheet.Cells(1, i).Value, 1, 10) + month + "/" + Mid(Split(wbkExtract.ActiveSheet.Cells(1, i).Value, "/")(2), 3, 2)
End If
If UCase(Mid(wbkExtract.ActiveSheet.Cells(1, i).Value, 1, 3)) = "LCD" Then
month = Split(wbkExtract.ActiveSheet.Cells(1, i).Value, "/")(2)
If Len(month) = 1 Then
month = "0" + month
End If
ThisWorkbook.Worksheets("RawData").Cells(1, i + 4).Value = Mid(wbkExtract.ActiveSheet.Cells(1, i).Value, 1, 14) + month + "/" + Mid(Split(wbkExtract.ActiveSheet.Cells(1, i).Value, "/")(3), 3, 2)
End If
i = i + 1
Loop
wbkExtract.ActiveSheet.Cells(1, 1).EntireRow.Delete
vData = wbkExtract.ActiveSheet.Cells(1, 1).CurrentRegion.Value
wbkExtract.Close savechanges:=False
vCleanData = CleanRawData(vData, sMarket)
sLastCellAddress = ThisWorkbook.Worksheets("RawData").Cells(UBound(vCleanData, 1) + 1, UBound(vCleanData, 2)).Address(RowAbsolute:=False, ColumnAbsolute:=False)
ThisWorkbook.Worksheets("RawData").Range("A2:" & sLastCellAddress).Value = vCleanData
' Get List of Unique Countries
On Error Resume Next
For i = 1 To UBound(vCleanData, 1)
cnCountries.Add vCleanData(i, 2), vCleanData(i, 2)
Next i
On Error GoTo 0
ThisWorkbook.Worksheets("Market").Cells(1, 1).CurrentRegion.Clear
ThisWorkbook.Worksheets("Market").Cells(1, 1).Value = "Country"
ThisWorkbook.Worksheets("Market").Cells(1, 2).Value = "Group 1"
ThisWorkbook.Worksheets("Market").Cells(1, 3).Value = "Group 2"
ThisWorkbook.Worksheets("Market").Cells(1, 4).Value = "Group 3"
ThisWorkbook.Worksheets("Market").Cells(1, 5).Value = "Group 4"
ThisWorkbook.Worksheets("Market").Range("A1:G1").Font.Bold = True
For i = 1 To cnCountries.Count
ThisWorkbook.Worksheets("Market").Cells(i + 1, 1).Value = cnCountries.Item(i)
Next i
End Sub
Sounds like a broken code cache.
I've seen errors happen like this before in older format (xls) workbooks and it can be a sign of problems in the file overall.
Try the compile option suggested by #Scott Holtzman first. In some cases I've seen the recompile not work and if that happens just force a compile by making a change to the code. A trivial change is enough usually.
If that doesn't work then (to help disagnose a corruption issue) try copying the code into a new workbook and see what happens there. If it runs in the new sheet then I wouldn't waste more time on it and just rebuild the sheet, trust me it'll be quicker than messing about troublshooting the one you have.