I am quite new to VBA, the code below is what I have managed so far but I would like to ask if someone can help with formatting and formulae copying please?
I have the below code running in my project that transfers data from a worksheet called "Update Quality Check Data" to other worksheets based on user names by 1 of 2 ways, either:
By seeing the user name of the worksheet already exists and just
copying the relevant data; or,
By creating a new worksheet with the
user name as the ws name and copying the data from the data sheet
What I would like to add would be when a new user sheet is created the format and forumlas from the first usersheet are copied into the new sheets and each additional user sheet that is created.
I have seen many threads to copy paste and the arguments between clipboard and pastespecial but now I am rather confused and not sure how to do this for sheets that do not currently exist. Could some please help me?
Public Sub transfer()
Dim ws As Worksheet, wsName As Worksheet
Dim lRow As Long, lPaste As Long
Dim sName As String
Set ws = Worksheets("Update Quality Check Data")
With ws
For lRow = 2 To .Cells(Rows.Count, 1).End(xlUp).Row
sName = .Cells(lRow, 2)
On Error Goto NoSheettFound
Jumper:
Set wsName = Worksheets(sName)
On Error Goto 0
lPaste = wsName.Cells(Rows.Count, 3).End(xlUp).Row + 1
.Cells(lRow, 1).Copy Destination:=wsName.Cells(lPaste, 3)
.Cells(lRow, 3).Copy Destination:=wsName.Cells(lPaste, 4)
Next lRow
End With
Exit Sub
NoSheettFound:
Set wsName = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
wsName.Name = sName
ws.Select
Goto Jumper
End Sub
Kind Regards
John
I've done this two ways. One, create a template that's a hidden tab that I copy my format from.
Or two, you can bury EACH cell's format in your code and call it for each range you want. Example:
Sub format1(r As Range)
With r
.Interior
.Interior.Pattern = xlSolid
.Interior.PatternColorIndex = xlAutomatic
.Interior.ThemeColor = xlThemeColorAccent1
.Interior.TintAndShade = 0.799981688894314
.Interior.PatternTintAndShade = 0
.Font.ThemeColor = xlThemeColorAccent2
.Font.TintAndShade = 0.399975585192419
.Font.Size = 12
.Font.Bold = True
.Font.Italic = True
.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
.Borders(xlEdgeLeft).LineStyle = xlNone
.Borders(xlEdgeTop).LineStyle = xlContinuous
.Borders(xlEdgeTop).ColorIndex = 0
.Borders(xlEdgeTop).TintAndShade = 0
.Borders(xlEdgeTop).Weight = xlThin
.Borders(xlEdgeBottom).LineStyle = xlDouble
.Borders(xlEdgeBottom).ColorIndex = 0
.Borders(xlEdgeBottom).TintAndShade = 0
.Borders(xlEdgeBottom).Weight = xlThick
.Borders(xlEdgeRight).LineStyle = xlNone
.Borders(xlInsideVertical).LineStyle = xlNone
.Borders(xlInsideHorizontal).LineStyle = xlNone
End With
End Sub
here's one using a template:
Sub FormatNewSheet(ws As Worksheet)
Dim wsTemplate As Worksheet
Set wsTemplate = Worksheets("Bob")
Application.EnableEvents = False
Application.ScreenUpdating = False
Application.CutCopyMode = False
'Copy the range from the template
wsTemplate.Range("D5:G10").Copy
'Paste the format to the new range
ws.Select
ws.Range("D5:G10").Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.EnableEvents = True
Application.CutCopyMode = xlCopy
Application.ScreenUpdating = True
End Sub
Here is a simple test for it, passing the worksheet name to the format sub:
Sub TestFormat()
Dim ws As Worksheet
Set ws = Worksheets("my new sheet")
Call FormatNewSheet(ws)
End Sub
I hope that helps!
Related
Hi and thank you for any help with this, currently I have code that copy and pastes text from a named range then I have code that formats it however the range needs to be dynamic, I have it just set to do where my first table shows but I have over 50 tables that will be copy and pasted over:
Here is my code for the Text to be copy and pasted over:
Private Sub CommandButton1_Click()
Application.ScreenUpdating = False
Dim copySheet As Worksheet
Dim pasteSheet As Worksheet
Set copySheet = Worksheets("Auto")
Set pasteSheet = Worksheets("Final")
copySheet.Range("Range1").Copy
pasteSheet.Cells(Rows.Count, 1).End(xlUp).Offset(2, 0).PasteSpecial xlPasteValues
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
Here is my code for the Formatting:
Private Sub CommandButton2_Click()
ThisWorkbook.Worksheets("Final").Range("A1:E15").Columns.AutoFit
ThisWorkbook.Worksheets("Final").Range("A3:E3").Interior.Color = RGB(180, 198, 231)
ThisWorkbook.Worksheets("Final").Range("A19:D19").Merge
ThisWorkbook.Worksheets("Final").Range("A4:A18").Merge
ThisWorkbook.Worksheets("Final").Range("A4:A17").HorizontalAlignment = -4131
ThisWorkbook.Worksheets("Final").Range("A4:A17").VerticalAlignment = -4160
ThisWorkbook.Worksheets("Final").Range("A19:D19").Interior.ColorIndex = 48
ThisWorkbook.Worksheets("Final").Range("A3:E19").Borders.LineStyle = xlContinuous
ThisWorkbook.Worksheets("Final").Range("A3:E19").Borders.Color = vbBlack
ThisWorkbook.Worksheets("Final").Range("A3:E19").Borders.Weight = xlThin
ThisWorkbook.Worksheets("Final").Range("A3:E3").Font.Bold = True
ThisWorkbook.Worksheets("Final").Range("D4:E18", "E19").Style = "Currency"
ThisWorkbook.Worksheets("Final").Range("E19").Font.Bold = True
End Sub
As you can see the code for the formatting is not dynamic but static, how would I make this dynamic, or how would I go about implementing this formatting into the text code so that it copys and pasted the text across and then formats it?
End result should look like:
Use a combination of Offset and Resize
Option Explicit
Private Sub CommandButton1_Click()
Application.ScreenUpdating = False
Dim copySheet As Worksheet, pasteSheet As Worksheet
Dim ar, r, rng As Range
ar = Array("Range1", "Range2", "Range3")
Set copySheet = Worksheets("Auto")
Set pasteSheet = Worksheets("Final")
For Each r In ar
Set rng = pasteSheet.Cells(Rows.Count, 1).End(xlUp).Offset(2, 0)
copySheet.Range(r).Copy rng
Call ApplyFormat(rng)
Next
Application.ScreenUpdating = True
End Sub
Private Sub ApplyFormat(ByVal rng As Range)
Set rng = rng.Cells(1, 1) ' top left corner
rng.Resize(15, 5).Columns.AutoFit ' A1:E15
With rng.Offset(2, 0).Resize(1, 5) ' A3:E3
.Interior.Color = RGB(180, 198, 231)
.Font.Bold = True
End With
With rng.Offset(18, 0).Resize(1, 4) ' A19:D19
.Merge
.Interior.ColorIndex = 48
End With
With rng.Offset(3, 0).Resize(15, 1) ' A4:A18
.Merge
.HorizontalAlignment = -4131
.VerticalAlignment = -4160
End With
With rng.Offset(2, 0).Resize(17, 5).Borders ' A3:E19
.LineStyle = xlContinuous
.Color = vbBlack
.Weight = xlThin
End With
rng.Offset(3, 3).Resize(15, 2).Style = "Currency" ' D4:E18
With rng.Offset(18, 4) ' E19
.Style = "Currency"
.Font.Bold = True
End With
End Sub
I've provided a password to unprotect active sheet to perform a Macros but still, it is asking a password to perform some parts of it (1) For changing case to Uppercase and (2) for clearing contents. I don't know why? Could you help me where I am wrong! My code is -
Sub REFRESH_DATA()
Dim rng As Range
Dim last As Long
Application.ScreenUpdating = False
ActiveSheet.Unprotect Password:="****"
Set rng = Range("A8:R" & last)
last = Range("B99000").End(xlUp).Row
With rng.Borders ' Blue border
.LineStyle = xlContinuous
.Color = vbBlue
.Weight = xlThin
End With
If Range("B8") <> "" Then ''''''' Upper case''''''
ActiveSheet.Range("B8:L21000").SpecialCells(xlCellTypeConstants).Select
With Selection
.Value = UCase(.Value)
End With
End If
Range("A" & last + 1 & ":R" & 90000).ClearContents
ActiveSheet.Protect Password:="****"
End Sub
if i understood your question you have to:
1)unprotect all the sheet
example
dim ws as Worksheet
For Each ws In Worksheets
ws.Unprotect Password:=pwd
Next ws
'your code and active the sheet with the name
example
Worksheets(sheetname).Activate
and as last operation protect all sheets
For Each ws In Worksheets
ws.Protect Password:=pwd
Next ws
Hope this helps
I have a hierarchy codification system within a sheet column. I would like looking for values within that column that match in partially way with values on that column also. The search should start from longer values. Here the sample:
AME_ASO_010_010_010
AME_ASO_010_010_010_010 (longer values, search starting)
In summary i look for some ideas for finding matches, without taking into account last four places (_010).
Thanks to all!
Any support will be appreciated!
With the contribution of dwirony, im trying this. Would somebody please know why is giving me object required error (424). Many thanks!
it Fails in line > Left(cell, Len(cell) - 4).Offset(, 1).Select
Sub main()
Dim cell As Range
Dim arr As Variant, arrElem1 As Variant
Dim rng As Range
Dim sh1 As Worksheet
Set sh1 = Sheets("Valeurs")
With Worksheets("Valeurs")
For Each cell In .Range("E1", .Cells(.Rows.Count, "E").End(xlUp))
Set rng = Range(cell, cell.Offset(0, 12))
arr = Split(Replace(cell.Value, " ", " "), " ")
For Each arrElem1 In arr
If Len(arrElem1) = 15 Then
Left(cell, Len(cell) - 4).Offset(, 1).Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent4
.TintAndShade = -0.249977111117893
.PatternTintAndShade = 0
End With
End If
Next arrElem1
Next cell
End With
End Sub
Trying and trying the success has arrived!
Here the code, maybe it will be useful for others.
Subject closed!
Sub main()
Dim i As Long
Dim cell As Range
Dim lResult As String
Dim arr As Variant, arrElem1 As Variant
Dim rng As Range, rng1 As Range
Dim sh1 As Worksheet
With Worksheets("Valeurs")
For Each cell In .Range("E1", .Cells(.Rows.Count, "E").End(xlUp))
arr = Split(Replace(cell.Value, " ", " "), " ")
For Each arrElem1 In arr
If Len(arrElem1) = 15 Then
lResult = Left(arrElem1, Len(arrElem1) - 4)
Set rng1 = sh1.Range("E15:E10000")
Set Findv = Range("E15:E10000").Cells.Find(What:=lResult, LookAt:=xlWhole, _
After:=Range("E15"), SearchDirection:=xlPrevious)
Findv.Offset(0, 1).Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent4
.TintAndShade = -0.249977111117893
.PatternTintAndShade = 0
End With
End If
Next arrElem1
Next cell
End With
End Sub
I have a code that does what I want it to do, but it's HUGE, as i used the macro recorder to make it. Basically, it selects a range, applies two conditional formats and goes to the next range. I can't select the whole ranges at once because the conditional format applies an AVERAGE on each range.
Here's a piece of the code:
Sub DesvPad()
Range("C3:N3").Select
Selection.FormatConditions.AddAboveAverage
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
Selection.FormatConditions(1).AboveBelow = xlAboveStdDev
With Selection.FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.Color = 5296274
.TintAndShade = 0
End With
Selection.FormatConditions(1).NumStdDev = 1
Selection.FormatConditions(1).StopIfTrue = False
Selection.FormatConditions.AddAboveAverage
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
Selection.FormatConditions(1).AboveBelow = xlBelowStdDev
With Selection.FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.Color = 49407
.TintAndShade = 0
End With
Selection.FormatConditions(1).NumStdDev = 1
Selection.FormatConditions(1).StopIfTrue = False
MsgBox "O macro foi executado até Range(C325:N325)"
End Sub
I know it's shameful, so I'll appreciate any help!
It's not really clear what your question is but I'll guess you're asking how to make your code more "modular" "
Sub Tester()
ApplyCF Range("A1:A10")
ApplyCF Range("A11:A20")
'etc
End Sub
Sub ApplyCF(rng As Range)
'here use rng instead of "Selection"
rng.FormatConditions.AddAboveAverage '<< for example
End Sub
I think this could help:
Sub formatInMySelectedSheets() 'use this just for few sheet
'that you want to change
Dim i As Worksheet
Dim Nm(1 To 3) As String
Dim s
Dim sht As Worksheet
'Imagine the book has 10 sheets, "Sheet1" to "Sheet10"
'but you only want to go to Sheet1, Sheet4 and Sheet7
Nm(1) = "Sheet1" 'this are the sheets you want to change
Nm(2) = "Sheet4"
Nm(3) = "Sheet7"
For Each i In ActiveWorkbook.Worksheets 'the workbook with the sheets...
For s = LBound(Nm) To UBound(Nm) 'from the lowest value of the array to
'to the highest
Set sht = Sheets(Nm(s))
'here the code shows the sheet to avoid some errors
'if the sheet is hidden, Show it to me!
If sht.Visible = xlSheetVeryHidden Or sht.Visible = xlSheetHidden Then
sht.Visible = xlSheetVisible
End If
'go to the sheet
sht.Activate
DesvPad 'Calls you code
Next s
Next i
End Sub
Sub formatInEverySheet() 'Use this to do it in every sheet
'no matter what!
Dim i As Worksheet
For Each i In ActiveWorkbook.Worksheets
i.Activate
' here the code shows the sheet to avoid some errors
If i.Visible = xlSheetVeryHidden Or i.Visible = xlSheetHidden Then
i.Visible = xlSheetVisible
End If
DesvPad 'Calls you code
Next i
End Sub
Last week, I found an excellent code that I've been looking for. Except that I would like to use conditional formatting vertical, not horizontal as in the original code.
The orginal code is found from: Excel VBA - How do I select a range corresponding to values in previous cells?
I tried to modify the code to suit me, but there is still something wrong and I don't know what.
There is my code:
Sub tee()
Dim startRow As Long
Dim endRow As Long
Dim i As Long
Dim j As Long
Dim ws As Excel.Worksheet
Dim entryTime As Single
Dim exitTime As Single
Dim formatRange As Excel.Range
Set ws = ActiveSheet
startRow = ws.Range("19:19").Row
endRow = ws.Range("56:56").Row
Call clearFormats
For i = 3 To ws.Cells(1, 1).End(xlToRight).Column
entryTime = ws.Cells(15, i).Value
exitTime = ws.Cells(16, i).Value
Set formatRange = Nothing
For j = startRow To endRow
If (ws.Cells(j, 2).Value > exitTime) Then
Exit For
End If
If ((entryTime < ws.Cells(j, 2).Value) And (ws.Cells(j, 2).Value < exitTime)) Then
If (formatRange Is Nothing) Then
Set formatRange = ws.Cells(j, i)
Else
Set formatRange = formatRange.Resize(, formatRange.Rows.Count + 1)
End If
End If
Next j
If (Not formatRange Is Nothing) Then
Call formatTheRange(formatRange, ws.Cells(j, "A").Value)
End If
Next i
End Sub
Private Sub clearFormats()
With ActiveSheet.Range("C19:AA56")
.clearFormats
.ClearContents
End With
End Sub
Private Sub formatTheRange(ByRef r As Excel.Range, ByRef callsign As String)
r.HorizontalAlignment = xlCenter
r.Merge
r.Value = callsign
' Apply color
With r.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorLight2
.Color = 3
.TintAndShade = 0.799981688894314
.PatternTintAndShade = 0
End With
' Apply borders
With r.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With r.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With r.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With r.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
End Sub
The last two is ordinary code. I have change only the first one.
I don't have a lot of programming with VBA, but I'm trying hard.
Jukkis
The picture tells a thousand words! Here is some code that works. I have simplified your code considerably, rather than trying to learn what you did (and why it didn't work). Feel free to compare with your original, and figure out why one works when the other didn't.
Note - I use the MATCH function to find the rows where you start/end, then format the entire column in a single step. Since I made a smaller sheet, some of the row/column numbers are different - it should be easy to see where you have to change things in the code to work for you.
Option Explicit
Sub makeTimeGraph()
Dim startRow As Long
Dim endRow As Long
Dim entryTimeRow As Long
Dim entryTimeFirstCol As Long
Dim ws As Excel.Worksheet
Dim timeRange As Range
Dim c
Dim timeCols As Range
Dim entryTime
Dim exitTime
Dim formatRange As Excel.Range
Dim eps
eps = 1e-06 ' a very small number - to take care of rounding errors in lookup
' change these lines to match the layout of the spreadsheet
' first cell of time entries is B1 in this case:
entryTimeRow = 1
entryTimeFirstCol = 2
' time slots are in column A, starting in cell A3:
Set timeRange = Range("A3", [A3].End(xlDown))
' columns in which times were entered:
Set ws = ActiveSheet
Set timeCols = Range("B1:H1) ' select all the columns you want here, but only one row
' clear previous formatting
Range("B3", ws.Cells.SpecialCells(xlCellTypeLastCell)).clearFormats
' loop over each of the columns:
For Each c In timeCols.Cells
If IsEmpty(c) Then Goto nextColumn
entryTime = c.Value
exitTime = c.Offset(1, 0).Value
startRow = Application.WorksheetFunction.Match(entryTime + eps, timeRange) + timeRange.Cells(1.1).Row - 1
endRow = Application.WorksheetFunction.Match(exitTime - eps, timeRange) + timeRange.Cells(1.1).Row - 1
Set formatRange = Range(ws.Cells(startRow, c.Column), ws.Cells(endRow, c.Column))
Call formatTheRange(formatRange)
nextColumn:
Next c
End Sub
Private Sub formatTheRange(ByRef r As Excel.Range)
r.HorizontalAlignment = xlCenter
r.Merge
' Apply color
With r.Interior
.Pattern = xlSolid
.Color = 3
.TintAndShade = 0.8
End With
End Sub
Here is the result: