I have the following code, and I need to make the inserted text bold. How do I add this to my statement (can't figure out the syntax)? Thanks!
Dim ws As Worksheet
Dim addme As Long
Set ws = Worksheets("Projects")
addme = ws.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
' Insert data from UserForm into Columns 2 & 3
With ws
ws.Cells(addme, 2).value = Me.SuperProject1.value 'the number 2 here represents the Column B
ws.Cells(addme, 3).value = Me.SProjectName1.value 'the number 3 represents Column C
End With
With ws
.Cells(addme, 2).value = Me.SuperProject1.value
.Cells(addme, 3).value = Me.SProjectName1.value
.Cells(addme, 2).Resize(1, 2).Font.Bold = True
End With
Related
I am wrting code for an excel spreadsheet to record change numbers such as 1735.01 .1735.02 for example but when it exceeds 1735.10 it outputs 1735.01 then 1735.011 where i would like 1735.10, 1735.11 up to 99,
can anyone help?
Option Explicit
Dim ws As Worksheet
Set ws = ActiveSheet
Dim newcolumn As Long
Dim i As Integer
Dim CELL As Range
newcolumn = Application.WorksheetFunction.CountA(ws.Range("A:A")) + 1
'The next two lines can be expanded as many times as needed for all the entry fields in your project
ws.Cells(newcolumn, 1).Value = Me.TextBox2.Value
ws.Cells(newcolumn, 2).Value = Me.TextBox3.Value
ws.Cells(newcolumn, 3).Value = Date
ws.Cells(newcolumn, 5).Value = Me.TextBox1.Value
ws.Cells(newcolumn, 4).Value = ws.Name & ".0" & Application.WorksheetFunction.CountA(ws.Range("D:D"))
End Sub
below is an amige of the output on the spreadsheet
[](https://i.stack.imgur.com/Ck7qZ.jpg)Private Sub CommandButton1_Click()
I am trying to build a code to check for two conditions simultaneously from my data file. Currently my script works fine because its only checking for the brand name on column A. However I also want to check for the category on column B whether its a "Sun" or "Vista".
Structurally I want something like:
For i = 2 to Last_row
If Cells(i,1).value = "BananaRepublic" and Cells(i, 2).value = "Sun" or "Vista" then,
Row(i).Copy
Worksheet(new_worksheet).Paste
Please note: on an average there are over 30 different brands that I need to enter in this list which need to be matched with their value on column B(Sun/Vista) and I then need to replicate this for 20 different macros each for a different combination of brand names and Sun/Optical category. Doing it individually seems very inefficient. Is there a better solution?
Here's what I've done so far:
Option Compare Text
Sub StarOptical()
'Define all variables
Dim customer_name As String
Dim sheetName As String
sName = ActiveSheet.Name
'ActiveWorkbook.Worksheets(sName).Sort.SortFields.Clear
'Enter the Customer Name here
customer_name = "StarOptical"
Sheets.Add.Name = customer_name
'Copy same header to the new worksheet
Worksheets(sName).Rows(1).Copy
Worksheets(customer_name).Cells(1, 1).Select
ActiveSheet.Paste
'Find the last row of the report
last_row = Worksheets(sName).Cells(Rows.Count, 1).End(xlUp).Row
'Start the loop and scan through each row for listed brands
For i = 2 To last_row
'Update the names of the approved brands in the line below
If Worksheets(sName).Cells(i, 1).Value = "ADENSCO" Or Worksheets(sName).Cells(i, 1).Value = "BANANAREPUBLI" Or Worksheets(sName).Cells(i, 1).Value = "BOSS(HUB)" Then
Worksheets(sName).Rows(i).Copy
Worksheets(customer_name).Activate
last_row_new = Worksheets(customer_name).Cells(Rows.Count, 1).End(xlUp).Row
Worksheets(customer_name).Cells(last_row_new + 1, 1).Select
ActiveSheet.Paste
End If
Next
Application.CutCopyMode = False
Worksheets(customer_name).Cells(1, 1).Select
End Sub
You can do something like this:
Sub tester()
CreateSheet "BananaRepublic", Array("Sun", "Vista")
'etc for other sheets
End Sub
Sub CreateSheet(sBrand As String, arrVals)
Dim wsSrc As Worksheet, wsDest As Worksheet, i As Long, c As Range
Set wsSrc = ActiveSheet
Set wsDest = wsSrc.Parent.Sheets.Add()
wsDest.Name = sBrand
wsSrc.Rows(1).Copy wsDest.Cells(1, 1)
Set c = wsDest.Cells(2, 1)
For i = 2 To wsSrc.Cells(Rows.Count, 1).End(xlUp).Row
'match on ColA?
If wsSrc.Cells(i, 1).Value = sBrand Then
'match on colB ?
If Not IsError(Application.Match(wsSrc.Cells(i, 2).Value, arrVals, 0)) Then
wsSrc.Rows(i).Copy c 'copy the row
Set c = c.Offset(1, 0) 'next cell down for copy destination
End If
End If
Next
End Sub
I have some code that creates worksheets based on a cell value in a column and then I have the below code which will scan the same column and move the entire row of that sheet to the matching sheet name.
Sub CopyRowData()
'Declare variables
Dim x As Integer
Dim y As Integer
Dim i As Integer
Dim shSource As Worksheet
Dim shTarget1 As Worksheet
Dim shTarget2 As Worksheet
Dim shTarget3 As Worksheet
Dim shTarget4 As Worksheet
Dim shTarget5 As Worksheet
Dim shTarget6 As Worksheet
'Assign string values to variables
Set shSource = ThisWorkbook.Sheets("1")
Set shTarget1 = ThisWorkbook.Sheets("2")
Set shTarget2 = ThisWorkbook.Sheets("3")
Set shTarget3 = ThisWorkbook.Sheets("4")
Set shTarget4 = ThisWorkbook.Sheets("5")
Set shTarget5 = ThisWorkbook.Sheets("6")
Set shTarget6 = ThisWorkbook.Sheets("7")
'Locate the rows to be checked
'2
If shTarget1.Cells(3, 6).Value = "" Then
a = 3
Else
a = shTarget1.Cells(3, 6).CurrentRegion.Rows.Count + 3
End If
'3
If shTarget2.Cells(3, 6).Value = "" Then
b = 3
Else
b = shTarget2.Cells(3, 6).CurrentRegion.Rows.Count + 3
End If
'4
If shTarget3.Cells(3, 6).Value = "" Then
c = 3
Else
c = shTarget3.Cells(3, 6).CurrentRegion.Rows.Count + 3
End If
'5
If shTarget4.Cells(3, 6).Value = "" Then
d = 3
Else
d = shTarget4.Cells(3, 6).CurrentRegion.Rows.Count + 3
End If
'6
If shTarget5.Cells(3, 6).Value = "" Then
e = 3
Else
e = shTarget5.Cells(3, 6).CurrentRegion.Rows.Count + 3
End If
'7
If shTarget6.Cells(3, 6).Value = "" Then
f = 3
Else
f = shTarget6.Cells(3, 6).CurrentRegion.Rows.Count + 3
End If
i = 3
'Do while that will read the data of the cells in the 5th column and if it is match for the string variables, it will move the entire row to the worksheet of the same name
Do While i <= 200
'2
If Cells(i, 6).Value = "2" Then
shSource.Rows(i).Copy
shTarget1.Cells(a, 1).PasteSpecial Paste:=xlPasteValues
shSource.Rows(i).Delete
a = a + 1
GoTo Line1
'3
ElseIf Cells(i, 6).Value = "3" Then
shSource.Rows(i).Copy
shTarget2.Cells(b, 1).PasteSpecial Paste:=xlPasteValues
shSource.Rows(i).Delete
b = b + 1
GoTo Line1
End If
'4
If Cells(i, 6).Value = "4" Then
shSource.Rows(i).Copy
shTarget3.Cells(c, 1).PasteSpecial Paste:=xlPasteValues
shSource.Rows(i).Delete
c = c + 1
GoTo Line1
'5
ElseIf Cells(i, 6).Value = "5" Then
shSource.Rows(i).Copy
shTarget4.Cells(d, 1).PasteSpecial Paste:=xlPasteValues
shSource.Rows(i).Delete
d = d + 1
GoTo Line1
End If
'6
If Cells(i, 6).Value = "6" Then
shSource.Rows(i).Copy
shTarget5.Cells(e, 1).PasteSpecial Paste:=xlPasteValues
shSource.Rows(i).Delete
e = e + 1
GoTo Line1
'7
ElseIf Cells(i, 6).Value = "7" Then
shSource.Rows(i).Copy
shTarget6.Cells(f, 1).PasteSpecial Paste:=xlPasteValues
shSource.Rows(i).Delete
f = f + 1
GoTo Line1
End If
i = i + 1
Line1: Loop
Set mysheet = ActiveSheet
Dim wrksht As Worksheet
For Each wrksht In Worksheets
wrksht.Select
Cells.EntireColumn.AutoFit
Next wrksht
mysheet.Select
End Sub
I get the "Run Time Error 9, Subscript out of range".
The reason I get this error is because the sheet does not exist.
So for example, when the sheets are being created based on their cell values and in the cell there's no actual number 4, then a sheet with the name "4" will obviously not be created.
Ideally I wanted to code it in a way that didn't require hard coded string variables to do the check, but I simply don't know how to create that dynamic piece of code. So this is what I have at the moment and I am hoping someone can either help clean up the code to not have hard coded variables (1,2,3,4...) and perhaps just do a check first if the sheet exists then look for the sheet name in the column OR do the same thing but just input some kind of if statement to determine if the sheet exists before it bombs out.
I'm thinking of something like:
If (sheet.name("4") exists) Then
Set shTarget4 = ThisWorkbook.Sheets("4")
Else
Resume
There's no need for me to keep the original sheet's data as this is not the source sheet.
The data from the first sheet comes from its source via means of a macro, so if I ever need to refer to the source data then it wont be an issue.
Also, the other reason is that each sheet will be saved as individual workbooks in a folder when my macro's are run so that I can send off each individual sheet to their respective departments.
Here's how I'd do it. Should be OK provided the values in Col F are valid sheet names.
Sub CopyData()
Dim shtSrc As Worksheet
Dim c As Range, ws, r As Long, v
Set shtSrc = ThisWorkbook.Sheets("Sheet1")
For Each c In shtSrc.Range(shtSrc.Cells(2, 6), shtSrc.Cells(Rows.Count, 6).End(xlUp)).Cells
v = c.Value
If Len(v) > 0 Then
With GetSheet(ThisWorkbook, v)
'first row with no value in ColF
r = .Cells(Rows.Count, 6).End(xlUp).Offset(1, 0).Row
If r < 3 Then r = 3 'start at 3rd row
.Rows(r).Value = c.EntireRow.Value 'copy row content (value only)
End With
End If
Next c
End Sub
'Return a worksheet from a workbook: if not there, create a new sheet
' with the supplied name and return that
Function GetSheet(wb As Workbook, theName) As Worksheet
Dim ws As Worksheet
On Error Resume Next
Set ws = wb.Worksheets(theName)
On Error GoTo 0
If ws Is Nothing Then
Set ws = wb.Worksheets.Add(after:=wb.Worksheets(wb.Worksheets.Count))
ws.Name = theName
End If
Set GetSheet = ws
End Function
as for your explicit question (looking for some If (sheet.name("4") exists) Then way) you could take advantage of this helper function:
Function IsSheetThere(shtName As String, sht As Worksheet) As Boolean
On Error Resume Next
Set sht = Worksheets(shtName)
IsSheetThere = Not sht Is Nothing
End Function
to be used like:
Dim targetSht As Worksheet
If IsSheetThere("4", targetSht) Then
... (code to handle existing sheet)
End If
While as for the more general request ("dynamic piece of code"), you could use AutoFilter() method of Range object to formerly filter your source sheet column F and then copy/paste values to proper target sheet in one shot
I'm assuming that:
"1" is the worksheet whose column 6 cells you want to loop through from row 3 to the last one and copy/paste entire rows to a target sheet whose name matches current cell value
source sheet column 6 has a header in row 2
Sub CopyRowData()
Dim sourceSht As Worksheet
Set sourceSht = ThisWorkbook.Sheets("1")
Dim iSht As Long
Dim targetSht As Worksheet
With sourceSht
With .Range("F2", .Cells(.Rows.Count, "F").End(xlUp))
For iSht = 2 To 7
If IsSheetThere(CStr(iSht), targetSht) Then
.AutoFilter Field:=1, Criteria1:=iSht
If Application.WorksheetFunction.Subtotal(103, .Cells) > 1 Then
Intersect(.Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).EntireRow, .Parent.UsedRange).Copy
With targetSht
.Cells(WorksheetFunction.Max(3, .Cells(.Rows.Count, 1).End(xlUp).Row), 1).PasteSpecial Paste:=xlPasteValues
.Cells.EntireColumn.AutoFit
End With
Application.CutCopyMode = False
End If
End If
Next
End With
.AutoFilterMode = False
End With
End Sub
I am very new to VBA. Just started reading it up 2 days ago. I am wondering how could I write a VB codes assigned to a button to read through the whole column and search for similar numbers.
After that identifying similar numbers, it would need to move on to another column to check if the character in the column are same too.
If both of the logic = true . How can i change the cell of the value of another column?
Sample data
For the current example. The code should know that the first column had matching numbers. After that it will check for the name which is "a" in the example. After that it will automatically change the point to 1 and 0. If there are 3 same ones it will be 1,0,0 for the point
You may try recording whatever you want to do with record macros first, then filter out the codes that are not necessary. If you do not know how to record it using macros, click on the link below. You can learn from the recorded macros and slowly improvise your codes in the future from the experience you may gain.
Here's [a link] (http://www.dummies.com/software/microsoft-office/excel/how-to-record-a-macro-in-excel-2016/)
As per image attached in image I am assuming numbers are in Column A, column to check characters is Column J and result needs to be displayed in Column O then try following code.
Sub Demo()
Dim dict1 As Object
Dim ws As Worksheet
Dim cel As Range, fCell As Range
Dim lastRow As Long, temp As Long
Dim c1
Set dict1 = CreateObject("Scripting.Dictionary")
Set ws = ThisWorkbook.Sheets("Sheet2") 'change Sheet2 to your data sheet
With ws
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row 'last row with data in Column A
c1 = .Range("A2:A" & lastRow)
For i = UBound(c1, 1) To 1 Step -1 'enter unique values with corresponding values in dict1
dict1(c1(i, 1)) = .Range("J" & i + 1) '+1 for Row 2
Next i
Set fCell = .Range("A2")
For Each cel In .Range("A2:A" & lastRow) 'loop through each cell in Column A
temp = WorksheetFunction.CountIf(.Range(fCell, cel.Address), cel) 'get count
If temp > 1 Then
If cel.Offset(0, 9) = dict1(cel.Value) Then
cel.Offset(0, 14).Value = 0
Else
cel.Offset(0, 14).Value = 1
End If
Else
cel.Offset(0, 14).Value = 1
End If
Next cel
End With
End Sub
EDIT
Sub Demo()
Dim ws As Worksheet
Dim lastRow As Long
Application.ScreenUpdating = False
Set ws = ThisWorkbook.Sheets("Sheet2") 'change Sheet3 to your data range
With ws
lastRow = .Cells(.Rows.count, "A").End(xlUp).Row 'last row with data in Column A
.Range("O2").Formula = "=IF(MOD(SUMPRODUCT(($A$2:$A2=A2)*($J$2:$J2=J2)),3)=1,1,0)" 'enter formula in Cell O2
.Range("O2").AutoFill Destination:=.Range("O2:O" & lastRow) 'drag formula down
.Range("O2:O" & lastRow).Value = .Range("O2:O" & lastRow).Value 'keep only values
End With
Application.ScreenUpdating = True
End Sub
I have a list of data in excel consisting of "Yes" and "No".
I need an IF statement that will only act on cells with the "Yes" value, and skip any cells with the "No" value.
For context, the 'value if true' clause of my IF statement is an indexmatchmatch which needs to return a value in the sheet based on the "Yes" or "No".
I understand this could have a simple solution using VBA, so if anyone has an excel based solution or VBA based solution they would be equally helpful.
I can add columns and rows to the dataset I am working with if needs be.
Try this:
Sub YesNo()
Dim lRow As Long
Dim sht As Worksheet
Set sht = Worksheets("Tabelle1")
lRow = sht.Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To lRow
If sht.Cells(i, 1).Value = "True" Then 'Modify Column
'Your Code
End If
Next i
End Sub
Use VBA to achieve it
Assume in sheet , you have
A Yes
B Yes
C No
A Yes
B No
C Yes
A No
B No
After running the macro, Sheet 2 will have only those rows which have yes in Sheet1. Please modify the code based on your requirement
Sub g()
Dim lastRow As Long
Dim sheet As Worksheet
Set sht = Worksheets("Sheet1")
Set sht1 = Worksheets("Sheet2")
lRow = sht.Cells(Rows.Count, 1).End(xlUp).Row
Dim j As Long
j = 1
For i = 1 To lRow
If sht.Cells(i, 2).Value = "Yes" Then
sht1.Cells(j, 1).Value = sht.Cells(i, 1).Value
j = j + 1
End If
Next i
End Sub