VBA - get first cell when comment cell is selected - excel

I have few sheet that i would like to read all comments from each sheet.
I managed to get the comments but what i could get is the first cell of the same row and column of the commented cell.( attached photo)
red - commented cell.
green - required cell value.
Sub ShowCommentsAllSheets()
'Update 20140508
Dim commrange As Range
Dim rng As Range
Dim ws As Worksheet
Dim newWs As Worksheet
Set newWs = Application.Worksheets("CRs")
newWs.Range("A1").Resize(1, 4).Value = Array("Sheet", "A", "Value", "Comment")
Application.ScreenUpdating = False
On Error Resume Next
For Each ws In Application.ActiveWorkbook.Worksheets
Set commrange = ws.Cells.SpecialCells(xlCellTypeComments)
If Not commrange Is Nothing Then
i = newWs.Cells(Rows.Count, 1).End(xlUp).Row
For Each rng In commrange
i = i + 1
newWs.Cells(i, 1).Resize(1, 4).Value = Array(ws.Name, rng.Address, rng.Value, rng.Comment.Text)
Next
End If
Set commrange = Nothing
Next
newWs.Cells.WrapText = False
Application.ScreenUpdating = True
End Sub


Perhaps just change this line?
newWs.Cells(i, 1).Resize(1, 5).Value = Array(ws.Name, rng.Address, rng.Value, rng.Comment.Text, ws.Cells(rng.Row, 2))

Related

Add data from one table to sheet as value

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).

How to copy paste data based on criteria?

I’m trying to make a button which on click will filter the database from a column of date for today’s date and copy the whole row of the following and paste them in a new sheet. I’m new to coding so please, help needed.
Private Sub CommandButton6_Click()
a = Worksheets("Follow Up").Cells(Rows.Count, 1).End(xlUp).Row
For i = 3 To a
If Worksheets("Follow Up").Cells(i, 15).Value = Date Then
Worksheets("Follow Up").Rows(i).Copy
Worksheets("today").Activate
Worksheets("today").Cells(2, 1).Select
ActiveSheet.Paste
End If
Next i

You could use an autofilter (note that the Sub will only look at today's date):
Private Sub CommandButton6_Click()
Dim wsFU As Worksheet
Dim wsTD As Worksheet
Set wsFU = Worksheets("Follow Up")
Set wsTD = Worksheets("today")
Application.DisplayAlerts = False
wsTD.Delete
Application.DisplayAlerts = True
a = wsFU.Cells(Rows.Count, 1).End(xlUp).Row
wsFU.AutoFilterMode = False
ActiveWorkbook.Sheets.Add(After:=ActiveWorkbook.Sheets(ActiveWorkbook.Sheets.Count)).Name = "today"
Set wsTD = Worksheets("today")
With wsFU.Range("A1:P" & a) 'adjust to end of data columns
.AutoFilter Field:=15, Criteria1:=Format(Date, "mm/dd/yy") ' adjust to what your date format looks like
.SpecialCells(xlCellTypeVisible).Copy Destination:=wsTD.Range("A2")
End With
wsFU.AutoFilterMode = False
End Sub

If Today Copy to Worksheet
The Code
Private Sub CommandButton6_Click()
Dim rngU As Range ' Union Range
Dim a As Long ' Source Last Row
Dim b As Long ' Target Last Row
Dim i As Long ' Source Row Counter
' Source Worksheet
With Worksheets("Follow Up")
a = .Cells(.Rows.Count, 1).End(xlUp).Row
For i = 3 To a
If .Cells(i, 15).Value = Date Then
If Not rngU Is Nothing Then
Set rngU = Union(rngU, .Cells(i, 1))
Else
Set rngU = .Cells(i, 1)
End If
End If
Next
End With
' Target Worksheet
If Not rngU Is Nothing Then
With Worksheets("today")
b = .Cells(.Rows.Count, 1).End(xlUp).Row
rngU.EntireRow.Copy .Rows(b + 1)
Set rngU = Nothing
End With
End If
End Sub

Excel VBA : To fill or replace blank value fast

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

input code needs a slight modification

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

l form to save data in Access

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

Resources