vba copy from cells to another sheet when value is yes - excel

So I have two sheets, one with info and one where the info should be copied too.
If DONE is marked yes, all the info in that row will be copied to the sheet called "FullpInfo2 (with a button). In the "template" on the picture. But I have no idea what to do now. Could someone just give me an idea how to continue this?
If I add a new row and giving it value "yes", it should rewrite the previous (Name, Drink, Food, Vehicle)
Sub CopyYes()
Dim c As Range
Dim j As Integer
Dim Source As Worksheet
Dim Target As Worksheet
Set Source = ActiveWorkbook.Worksheets("PersonalInfo")
Set Target = ActiveWorkbook.Worksheets("FullpInfo")
For Each c In Source.Range("E2:E100") ' Do 100 rows
If c = "yes" Then
Source.Rows(c.Row).Copy Target.Rows(j)
Target.Cells("B15").Value = Source.Cells("A").Value ' I dont know what to do here..
End If
Next c
End Sub

You could try:
Option Explicit
Sub CopyYes()
Dim cell As Range
Dim Source As Worksheet, Target As Worksheet
With ThisWorkbook
Set Source = .Worksheets("PersonalInfo")
Set Target = .Worksheets("FullpInfo")
End With
With Target
'Formatting
Call Module1.Formatting(.Range("B3"), "Name", "Titles")
Call Module1.Formatting(.Range("D3"), "Drink", "Titles")
Call Module1.Formatting(.Range("B6"), "Food", "Titles")
Call Module1.Formatting(.Range("D6"), "Vehicle", "Titles")
For Each cell In Source.Range("E2:E100")
If cell.Value = "yes" Then
'Values
Call Module1.Formatting(.Range("B4"), Source.Range("A" & cell.Row).Value, "Values")
Call Module1.Formatting(.Range("D4"), Source.Range("C" & cell.Row).Value, "Values")
Call Module1.Formatting(.Range("B7"), Source.Range("B" & cell.Row).Value, "Values")
Call Module1.Formatting(.Range("D7"), Source.Range("D" & cell.Row).Value, "Values")
End If
Next cell
End With
End Sub
Sub Formatting(ByVal rng As Range, str As String, strType As String)
With rng
.Value = str
.Font.Bold = True
If strType = "Values" Then
.Font.Color = vbBlue
End If
End With
End Sub

Related

VBA to remove formulas and keep values in every row IF a specific cell of the row is NOT empty

I have a basic understanding of Excel formulas but zero experience with VBA. I'm building a basic spreadsheet to keep track of people attendance. This spreadsheet is gonna be completed daily by people with even less understanding than me.
Column B is data validated from a DB table in another sheet. Columns D, E, F, G pull data from the same DB table using XLOOKUP based on the name on column B.
PROBLEM: If something in the DB table changes, like the account number of a person, every past attendance of that person is updated.
Example
I need a simple way to "lock" the data in cells that have been filled, although they should accept manual editing.
So far I'm tryng to put a button somewhere on the sheet that deletes all formulas but keeps tha value of the cells. I did some googling and got this:
Sub Remove_Formulas_from_Selected_Range()
Dim Rng As Range
Set Rng = Selection
Rng.Copy
Rng.PasteSpecial Paste:=xlPasteValuesAndNumberFormats
Application.CutCopyMode = False
End Sub
But I don't know how to adapt the button so it checks every row of the table, and if the Column B of that row is NOT emtpy (meaning the row is filled with a person's data) only THEN deletes the formulas of that row and keeps the values.
Your file must be an .xlsm file. Add an ActiveX button. Double click on it.
Inside the created button_click() sub add one line: call doTheJob
-After paste code below:
Private Sub doTheJob()
Dim rng As Range, rw As Long, c As Long
If TypeName(Selection) = "Range" Then
If MsgBox("Change formulas with Values in selected range?", vbDefaultButton2 + vbExclamation + vbYesNo) = vbYes Then
Set rng = Selection
rw = rng.Rows.CountLarge
Application.ScreenUpdating = False
For c = 1 To rw
If Trim(rng.Cells(c, 2).Value) <> "" Then
rng.Rows(c).Copy
rng.Rows(c).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
End If
Next
Application.CutCopyMode = False
End If
End If
End Sub
Before click the button you must select the range you interest to replace the formulas with the values.
This sub is for a sheet's module and one "fixed" table name
Private Sub doTheJob()
Dim rng As Range, rw As Long, c As Long
If MsgBox("Change formulas with Values in selected range?", vbDefaultButton2 + vbExclamation + vbYesNo) = vbYes Then
Set rng = Me.ListObjects("NameOfTable").Range
rw = rng.Rows.CountLarge
Application.ScreenUpdating = False
For c = 1 To rw
If Trim(rng.Cells(c, 2).Value) <> "" Then
rng.Rows(c).Copy
rng.Rows(c).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
End If
Next
Application.CutCopyMode = False
End If
End Sub
Use this code when the range is a Table. Modify the "NameOfTable" to the real name of your table.
This sub is for the Workbook an have to copy in a module inside folder "Modules". In sheets you wand to call this, add an ActiceX button and call the sub like below:
Public Sub doTheJob(ws As Worksheet, tablename As String)
Dim rng As Range, rw As Long, c As Long
If (Not ws Is Nothing) And tablename <> "" Then
Set rng = ws.ListObjects(tablename).Range
Else
MsgBox ("call the doTheJob with prameters a worksheet and a table name")
Exit Sub
End If
If Not rng Is Nothing Then
If MsgBox("Change formulas with Values in range " & tablename & " ?", vbDefaultButton2 + vbExclamation + vbYesNo) = vbYes Then
rw = rng.Rows.CountLarge
Application.ScreenUpdating = False
For c = 1 To rw
If Trim(rng.Cells(c, 2).Value) <> "" Then
rng.Rows(c).Copy
rng.Rows(c).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
End If
Next
Application.CutCopyMode = False
End If
Else
MsgBox ("doTheJob> Invalid table name")
End If
End Sub
'This sub is in sheets module
Private Sub CommandButton1_Click()
Call doTheJob(Me, Range("TABLE_NAMES").Value)
End Sub

How to find a Excel cell has hyperlink

I have data in Column A in excel..I am iterating through column and i need to find if a cell value has hyperlink init.
LR=Activeworkbook.Worksheets("Emp").Range("A65000").End(xlup).Row
for j=1 to LR
if Thisworkbooks.Worksheets("Emp").cells(j,1)="" then 'Logic to find hyperlink
'Function
end if
next
Identify Cells Containing Hyperlinks
As Red Hare already mentioned in the comments, it is best tested with something like the following:
Dim cell As Range: Set cell = Sheet1.Range("A1")
If cell.Hyperlinks.Count > 0 Then ' has a hyperlink
Else ' has no hyperlink
End If
that is, using the Hyperlinks.Count property of the Hyperlinks object returned by the cell's Hyperlinks property which is a collection of hyperlinks in a range (in this case, a single cell). For a single cell, the Count property will return only 0 or 1 so you could actually use
If cell.Hyperlinks.Count = 1 Then ' has a hyperlink
instead.
Example Code
Option Explicit
Sub IdentifyCellsWithHyperlink()
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' If it's not, modify accordingly.
Dim ws As Worksheet: Set ws = wb.Worksheets("Emp")
Dim rg As Range
Set rg = ws.Range("A2", ws.Cells(ws.Rows.Count, "A").End(xlUp))
Dim cell As Range
For Each cell In rg.Cells
If cell.Hyperlinks.Count > 0 Then ' has a hyperlink
Else ' has no hyperlink
End If
Next cell
End Sub
Here is something that can be used to run through each row to determine if it can be set as a hyperlink. Kinda hard to figure out what the range of possible solutions are that will work for you without fully understanding the context...
Private Sub cmdFollowLink_Click()
CreateHyperlink Me!cmdFollowLink, Me!txtSubAddress, _
Me!txtAddress
End Sub
Sub CreateHyperlink(ctlSelected As Control, _
strSubAddress As String, Optional strAddress As String)
Dim hlk As Hyperlink
Select Case ctlSelected.ControlType
Case acLabel, acImage, acCommandButton
Set hlk = ctlSelected.Hyperlink
With hlk
If Not IsMissing(strAddress) Then
.Address = strAddress
Else
.Address = ""
End If
.SubAddress = strSubAddress
.Follow
.Address = ""
.SubAddress = ""
End With
Case Else
MsgBox "The control '" & ctlSelected.Name _
& "' does not support hyperlinks."
End Select
End Sub

Paste Data To Range From User Form

I am looking for a little assistance with the VBA code in the workbook I have been working on. There is a userform with dependent dropdowns that pulls their values from "Master Sheet" in the workbook. The drop downs are functioning fine. However I have two roadblocks that I have now been able to get past. The first, The dropdowns allow the selection of "Category, Make, Model, and Add To". In the Master Sheet, "Category, Make, Model" Run from Columns A:C. Columns D:G have the equipment's, "Weight, Length, Width, Depth" information. I have not been able to have the information from columns A:F be copied based off the model selection. I have been trying have it paste in a test are for functionality with no luck. However once that would be functioning the "Add To" combo box selection in the user form would specify the range in the ECA worksheet to place that data. In the combo box selection, selecting "Keep" would place that information in range S3:Y16, "Remove" would be range S18:Y32, and "Final" would be range S35:Y47. Since numerous pieces of equipment would be added into each section when adding a piece of equipment it would place that entry in the next empty row of that range.
Link To Workbook
Picture Of Worksheets
Master Sheet
ECA Sheet
Dependent Drop Down Code
Private Sub cmbAddTo_Click()
'code needed to copy and add to selected range
End Sub
Private Sub cmdCancel_Click()
frmUser.Hide
End Sub
Private Sub UserForm_Initialize()
cmbCategory.RowSource = DynamicList(1, Null, 1, "Master Sheet", "Drop Down")
End Sub
Private Sub cmbCategory_Change()
cmbMake.RowSource = DynamicList(1, cmbCategory.Value, 2, "Master Sheet", "Drop Down")
End Sub
Private Sub cmbMake_Change()
cmbModel.RowSource = DynamicList(2, cmbMake.Value, 3, "Master Sheet", "Drop Down")
End Sub
Here is how I did it:
Function wsECA: Refers to the ECA worksheet
Enum SectonType: Numbers the sections
Function ECASection: Returns the range of a section
Function ECANewRow: Returns the range of the next empty row
Sub AddECANewRow: Add variable number of values to the new section row
Code
Public Enum SectonType
stExistingToRemain = 1
stRemoving
stFinal
End Enum
Public Sub AddECANewRow(SectionNumer As SectonType, ParamArray Values() As Variant)
Dim NewRow As Range
Set NewRow = ECANewRow(SectionNumer)
NewRow.Resize(1, UBound(Values) + 1).Value = Values
End Sub
Public Function wsECA() As Worksheet
Set wsECA = ThisWorkbook.Worksheets("ECA")
End Function
Public Function ECANewRow(ByVal SectionNumer As SectonType) As Range
Const LastColumn = 10
Dim Section As Range
Set Section = ECASection(SectionNumer)
Dim LastUsedRow As Long
Dim ColumnLastUsedRow As Long
For c = 2 To LastColumn
With Section.Columns(c)
ColumnLastUsedRow = .Cells(.Rows.Count, 1).End(xlUp).Row
If ColumnLastUsedRow > LastUsedRow Then LastUsedRow = ColumnLastUsedRow
End With
Next
LastUsedRow = LastUsedRow - Section.Row + 1
Set ECANewRow = Section.Cells(LastUsedRow + 1, 2).Resize(1, LastColumn - 1)
End Function
Function ECASection(ByVal SectionNumer As SectonType) As Range
Dim Target As Range
With wsECA
Set Target = Range("P2", .Cells(.Rows.Count, "P").End(xlUp))
End With
Dim MergedArea As Range
Dim Cell As Range
For Each Cell In Target
If Cell.MergeArea.Rows.Count > 1 Then
If MergedArea Is Nothing Then
Set MergedArea = Cell.MergeArea
SectionNumer = SectionNumer - 1
ElseIf MergedArea.Address <> Cell.MergeArea.Address Then
Set MergedArea = Cell.MergeArea
SectionNumer = SectionNumer - 1
End If
If SectionNumer = 0 Then Exit For
End If
Next
If Not MergedArea Is Nothing Then
Set ECASection = Range(MergedArea, MergedArea.EntireRow.Columns("AA"))
End If
End Function
Test
Application.Goto ECANewRow(stExistingToRemain), True
AddECANewRow stExistingToRemain,"Remain" ,3,,"Ford", "Mustang"
Application.Goto ECANewRow(stRemoving), True
AddECANewRow stFinal,"Removing" ,3,,"Chevy", "Tahoe"
Application.Goto ECANewRow(stFinal), True
AddECANewRow stRemoving,"Final" ,3,,"Dodge", "Journey"

Vlookup in another sheet

I am currently working on a userform. In this userform, data is entered in textbox4 and data is placed in textbox6 via commandbutton3 based on Vlookup. However, the vlookup must retrieve its data from the worksheet "DB - verzamelformulier" in the range A: B. Currently I get the error message: 424 object required. Can anybody help me with the code?
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("DB - verzamelformulier")
With ws
Texbox6.Formula = "VLookup(TextBox4.Value, DB - verzamelformulier!$A:$B), 2, False)"
End With
End Sub
Interesting approach, but you can't assign formulae to textboxes, only cells. Try out a function like this:
Function VerzamelFormulier(LookUpValue As Variant) As Variant
Dim WS As Worksheet
Dim R As Range
Set WS = ThisWorkbook.Worksheets("DB - verzamelformulier")
Set R = WS.Range("A:A").Find(LookUpValue, LookIn:=xlValues, Lookat:=xlWhole)
If R Is Nothing Then
' The value wasn't found.
Else
' Return the value from the cell in the same row and column B.
VerzamelFormulier = WS.Cells(R.Row, 2)
End If
End Function
Call it on TextBox4's change event so that whenever it's changed TextBox6's value is updated.
Private Sub TextBox4_Change()
TextBox6.Value = VerzamelFormulier(TextBox4.Value)
End Sub
Using Vlookup:
Option Explicit
Sub test()
Dim varResults As Variant
varResults = Application.VLookup(TextBox4.Value, ThisWorkbook.Worksheets("Db - verzamelformulier").Range("A:B"), 2, False)
If Not IsError(varResults) Then
'If there is a results
TextBox6.Value = varResults
Else
'If there is no result
End If
End Sub

I am getting an error Subscript Out of Range in Excel 2010

Sub RunCompare()
Call compareSheets("Latest", "SFDC")
End Sub
Sub compareSheets(shtLatest As String, shtSFDC As String)
Dim mycell As Range
Dim mydiffs As Integer
'For each cell in sheet2 that is not the same in Sheet1, color it yellow
For Each mycell In ActiveWorkbook.Worksheets(shtSFDC).UsedRange
If Not mycell.Value = ActiveWorkbook.Worksheets(shtLatest).Cells(mycell.Row, mycell.Column).Value Then
mycell.Interior.Color = vbYellow
mydiffs = mydiffs + 1
End If
Next
'Display a message box to demonstrate the differences
MsgBox mydiffs & " differences found", vbInformation
ActiveWorkbook.Sheets(SFDC).Select
End Sub
Sub RunCompare()
compareSheets "Latest", "SFDC"
End Sub
'Compares two sheets and colours yellow any cell in sheet2 that is not the same as in sheet 1
Sub compareSheets(sheet1 As String, sheet2 As String)
Dim rCell1 As Range
Dim rCell2 As Range
Dim nDiffs As Long ' Using a long because Integer may one day be too small
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Set ws1 = ActiveWorkbook.Worksheets(sheet1)
Set ws2 = ActiveWorkbook.Worksheets(sheet2)
For Each rCell1 In ws1.UsedRange.Cells
Set rCell2 = ws2.Range(rCell1.Address)
If rCell1.Value <> rCell2.Value Then
rCell2.Interior.Color = vbYellow
nDiffs = nDiffs + 1
End If
Next rCell1
Debug.Print nDiffs
End Sub
This should help you produce a workable solution. In your code, the 'For Each mycell' line creates a loop on each 'Range' object in 'UsedRange' not on each individual cell.
Your 'Subscript out of range' may become from invalid sheet names.
Are you sure that active book when you call macro is one with Latest and SFDC worksheets.
Not directly related to problem, but I would suggest you to change your function prototype to
Sub compareSheets(ByVal shtLatest As Worksheet, ByVal shtSFDC As Worksheet)
replace all ActiveWorkbook.Worksheets(shtSFDC) with shtSFDC (same for shtLatest) and finally replace call with
Call compareSheets(ActiveWorkbook.Worksheets("Latest"), ActiveWorkbook.Worksheets("SFDC"))
or directly with code name:
Call compareSheets(sheet1, sheet2)
That is clearer as compareSheets expects sheets, not text.

Resources