For some reason this Array isnt working! What could be wrong? Basically it is supposed to loop through every worksheet and give the same header to each worksheet.
WorksheetNames = Array("Sheet1", "Sheet2")
For Each ws In WorksheetNames
With Worksheets(ws)
.Range("F1").FormulaR1C1 = "PSTRIK"
.Range("A1").FormulaR1C1 = "PRECID"
.Range("C1").FormulaR1C1 = "PEXCH"
.Range("J1").FormulaR1C1 = "PQTY"
.Range("G1").FormulaR1C1 = "PCTYM"
.Range("D1").FormulaR1C1 = "PFC"
.Range("B1").FormulaR1C1 = "PACCT"
.Range("K1").FormulaR1C1 = "PPRTCP"
.Range("E1").FormulaR1C1 = "PSUBTY"
.Range("H1").FormulaR1C1 = "PSBCUS"
.Range("I1").FormulaR1C1 = "PBS"
End With
Next ws
I suspect something like this is what you're looking for:
Sub tgr()
Dim ws As Worksheet
Dim aHeaders As Variant
aHeaders = Array("PRECID", "PACCT", "PEXCH", "PFC", "PSUBTY", "PSTRIK", "PCTYM", "PSBCUS", "PBS", "PQTY", "PPRTCP")
For Each ws In ActiveWorkbook.Sheets
Select Case ws.Name
'any worksheet names listed here won't have their headers updated
Case "NoUpdate", "Leave Alone"
'Do nothing
'Update headers for all other sheets
Case Else
ws.Range("A1").Resize(, UBound(aHeaders) - LBound(aHeaders) + 1).Value = aHeaders
End Select
Next ws
End Sub
Related
What I want to do is to copy the same range("F2: F403") in the worksheetB in the workbookB
to the same range("F2:F403") in worksheet A in ThisWorkBook if the cells in worksheetB
is colored in green(colorIndex=4).
Otherwise, no doing copying.
I am pretty new in VBA(not used for one year).
Any help would be highly appreciated!
Thanks!
Option Explicit
Sub fillgreen()
Dim wb As Workbook: Set wb = ThisWorkbook
Dim ws, ws1, ws2 As Worksheet
Dim SUD_F As Range, S_Cell As Range, U_Cell As Range, Usage_F As Range
Dim i As Variant
Set ws1 = ThisWorkbook.Worksheets("WorksheetA")
Set ws2 = Workbooks("WorkbookB.xlsx").Worksheets("WorksheetB")
With ws1
Set SUD_F = ThisWorkbook.Worksheets("WorksheetA").Range("F2: F403")
End With
With ws2
Set Usage_F =_
Workbooks("WorkbookB.xlsx").Worksheets("WorksheetB").Range("F2: F403")
End With
' now fill the Usage_F green value to SUD_F
For i = 2 To 403
If Usage_F.Cells(i, "F").Value.Interior.ColorIndex = 4 Then
SUD_F.Cells(i, "F").Value = Usage_F.Cells(i, "F").Value
Else
SUD_F.Cells(i, "F").Value = SUD_F.Cells(i, "F").Value
End If
Next i
End Sub
Maybe more like this:
Sub fillgreen()
Dim SUD_F As Range, Usage_F As Range
Dim i As Long, v
Set SUD_F = ThisWorkbook.Worksheets("WorksheetA").Range("F2:F403")
Set Usage_F = Workbooks("WorkbookB.xlsx").Worksheets("WorksheetB").Range("F2:F403")
For i = 1 To Usage_F.Cells.Count
If Usage_F.Cells(i, "F").Interior.ColorIndex = 4 Then
SUD_F.Cells(i, "F").Value = Usage_F.Cells(i, "F").Value
Else
SUD_F.Cells(i, "F").Value = SUD_F.Cells(i, "F").Value '??
End If
Next i
End Sub
Many thanks to #Tim continuous help, and I know it is not easy to see the problem off hand. After searching for some other tutorial outside, I succeeded with the code below:
Option Explicit
Sub Color()
Dim Workbook As ThisWorkbook
Dim workksheet As Worksheet
Dim i As Variant
Dim S_range, U_range As Range
Dim rw As Range
Set S_range = ThisWorkbook.Worksheets("Journals with no use").Range("F2:F403")
Set U_range = ThisWorkbook.Worksheets("Use").Range("F2: F403")
For i = 2 To 403
If U_range.Cells.Rows(i).Interior.Color = RGB(198, 224, 180) Then
S_range.Cells.Rows(i).Value = U_range.Cells.Rows(i).Value
End If
Next i
End Sub
It reports "Run-time error '5': Invalid procedure call or argument" at line 37 "sh_DP_old.Copy After:=sh_new" only at the first-run. After clicking "debug" and doing nothing but re-running the code, it works well. Below is the code. Any help would be greatly appreciated.
Option Explicit
Public Function SheetFromCodeName(aName As String, wb As Workbook) As Worksheet
Dim sh As Worksheet
For Each sh In wb.Worksheets
If sh.CodeName = aName Then
Set SheetFromCodeName = sh
Exit For
End If
Next sh
End Function
Sub Note_Transfer()
Dim lastrow As Long
Dim MatchRow As Long
Dim firstopenrow As Long
Dim i As Long
Dim sh_old As Worksheet
Dim sh_new As Worksheet
Dim sh_DP_old As Worksheet
Dim sh_DP_new As Worksheet
Dim wb_old As Workbook
Dim wb_new As Workbook
Set wb_old = Workbooks(Workbooks.Count - 1)
Set wb_new = Workbooks(Workbooks.Count)
Set sh_old = SheetFromCodeName("Sheet1", wb_old)
Set sh_new = SheetFromCodeName("Sheet1", wb_new)
' transfer note if record matches
Set sh_DP_old = wb_old.Sheets("Discharged Patient")
sh_DP_old.Copy After:=sh_new
Set sh_DP_new = wb_new.Sheets("Discharged Patient")
lastrow = sh_old.Cells(Rows.Count, "A").End(xlUp).Row
For i = 2 To lastrow
If sh_old.Cells(i, 25) <> "Discharged patient" Then
MatchRow = Application.WorksheetFunction.Match(sh_old.Cells(i, 23).Value, sh_new.Range("W:W"), 0)
sh_new.Cells(MatchRow, 26).Resize(, 7).Value = sh_old.Cells(i, 26).Resize(, 7).Value
Else
firstopenrow = sh_DP_new.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).Row
sh_DP_new.Cells(firstopenrow, 1).Resize(, 32).Value = sh_old.Cells(i, 1).Resize(, 32).Value
End If
Next
sh_new.Select
End Sub
First, click Trust access to the VBA project object model via Excel Macro settings. Second, replace
Set sh_old = SheetFromCodeName("Sheet1", wb_old)
Set sh_new = SheetFromCodeName("Sheet1", wb_new)
with
With wb_old
Set sh_old = .Worksheets(CStr(.VBProject.VBComponents("Sheet1").Properties(7)))
End With
With wb_new
Set sh_new= .Worksheets(CStr(.VBProject.VBComponents("Sheet1").Properties(7)))
End With
And credit given to #John_Cunningham from Udemy.
Modified whole code is pasted below.
Option Explicit
Private Function SheetFromCodeName(aName As String, wb As Workbook) As Excel.Worksheet
Dim sh As Worksheet
For Each sh In wb.Worksheets
If sh.CodeName = aName Then
Set SheetFromCodeName = sh
Exit For
End If
Next sh
End Function
Sub Note_Transfer()
Dim lastrow As Long
Dim MatchRow As Long
Dim firstopenrow As Long
Dim i As Long
Dim sh_old As Worksheet
Dim sh_new As Worksheet
Dim sh_DP_old As Worksheet
Dim sh_DP_new As Worksheet
Dim wb_old As Workbook
Dim wb_new As Workbook
Set wb_old = Workbooks(Workbooks.Count - 1)
Set wb_new = Workbooks(Workbooks.Count)
With wb_old
Set sh_old = .Worksheets(CStr(.VBProject.VBComponents("Sheet1").Properties(7)))
End With
With wb_new
Set sh_new = .Worksheets(CStr(.VBProject.VBComponents("Sheet1").Properties(7)))
End With
' transfer note if record matches
Set sh_DP_old = wb_old.Sheets("Discharged Patient")
sh_DP_old.Copy After:=sh_new
Set sh_DP_new = wb_new.Sheets("Discharged Patient")
lastrow = sh_old.Cells(Rows.Count, "A").End(xlUp).Row
For i = 2 To lastrow
If sh_old.Cells(i, 25) <> "Discharged patient" Then
MatchRow = Application.WorksheetFunction.Match(sh_old.Cells(i, 23).Value, sh_new.Range("W:W"), 0)
sh_new.Cells(MatchRow, 26).Resize(, 7).Value = sh_old.Cells(i, 26).Resize(, 7).Value
Else
firstopenrow = sh_DP_new.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).Row
sh_DP_new.Cells(firstopenrow, 1).Resize(, 32).Value = sh_old.Cells(i, 1).Resize(, 32).Value
End If
Next
sh_new.Select
End Sub
I need some advice.
my code Check the cell "E" in sheet "Total" with the cell "B" in sheet "lists", if the values are equal it reads the cell "A" in the sheet "list" (which contains the name of all my sheets), and copies the match line in the correct sheet.
My script works but is very slow. Do you have any advice on how to speed up the process?
Currently the script read and copy line by line, I thought to speed up the process by applying automatic filter but do not know where to start ...
Thanks in advance.
This is my actual script:
Sub copystatus()
Dim LR As Long
Dim LC As Integer
Dim LB As Long
Dim ws As Worksheet
Dim ws2 As Worksheet
Dim ws3 As Worksheet
Dim cLista As String
Set ws = ThisWorkbook.sheets("totale")
Set ws2 = ThisWorkbook.sheets("liste")
LR = ws.Cells(Rows.Count, 5).End(xlUp).Row
LC = ws2.Cells(Rows.Count, 2).End(xlUp).Row
With ws
For x = 2 To LR
For i = 2 To LC
If .Cells(x, 5).value = ws2.Cells(i, 2).value Then
cLista = ws2.Cells(i, 1).value
Set ws3 = ThisWorkbook.sheets(cLista)
On Error GoTo ErrorHandler
LB = ws3.Cells(Rows.Count, 1).End(xlUp).Row
ws3.Rows(LB + 1).value = .Rows(x).value
ws3.Rows(1).value = .Rows(1).value
End If
Next i
Next x
End With
ErrorHandler:
End Sub
Check this out - the increase should be visible:
Sub copystatus()
Dim LR As Long
Dim LC As Integer
Dim LB As Long
Dim ws As Worksheet
Dim ws2 As Worksheet
Dim ws3 As Worksheet
Dim cLista As String
Application.ScreenUpdating = False
Application.EnableEvents = False
Set ws = ThisWorkbook.sheets("totale")
Set ws2 = ThisWorkbook.sheets("liste")
LR = ws.Cells(Rows.Count, 5).End(xlUp).Row
LC = ws2.Cells(Rows.Count, 2).End(xlUp).Row
With ws
For x = 2 To LR
For i = 2 To LC
If .Cells(x, 5).value = ws2.Cells(i, 2).value Then
cLista = ws2.Cells(i, 1).value
Set ws3 = ThisWorkbook.sheets(cLista)
On Error GoTo ErrorHandler
LB = ws3.Cells(Rows.Count, 1).End(xlUp).Row
ws3.Rows(LB + 1).value = .Rows(x).value
ws3.Rows(1).value = .Rows(1).value
End If
Next i
Next x
End With
Application.ScreenUpdating = True
Application.EnableEvents = True
ErrorHandler:
End Sub
And at the end set the ws, ws2, ws3 to Nothing like this:
Set ws = nothing
set ws2 = nothing
Something like this, starting with a 2 column data set
Sub ARRAY_WAY()
Dim arrSource() As Variant
Dim arrCheck() As Variant
Dim intArrayLoop As Integer
Dim intArrayLoop2 As Integer
arrSource = Range("A1:B7").Value
arrCheck = Range("C1:D3").Value
For intArrayLoop = 1 To UBound(arrSource)
For intArrayLoop2 = 1 To UBound(arrCheck)
If arrCheck(intArrayLoop2, 1) = arrSource(intArrayLoop, 1) Then
arrCheck(intArrayLoop2, 2) = arrSource(intArrayLoop, 2)
Exit For
End If
Next intArrayLoop2
Next intArrayLoop
Range("c1:d3").Value = arrCheck
End Sub
Will give an output like this (Columns C to D)
I assume that is another follow-up macro for your recent question?
As you already check for that condition and generate your worksheets there (cLista) it would be better off to copy the rows there in the first place.
With screen updating disabled as suggested by Vityata this should be running OK.
You can try and simplify this part:
Set ws3 = ThisWorkbook.sheets(cLista)
On Error GoTo ErrorHandler
LB = ws3.Cells(Rows.Count, 1).End(xlUp).Row
ws3.Rows(LB + 1).value = .Rows(x).value
ws3.Rows(1).value = .Rows(1).value
You might be better off without using set for ws3 and just simply refer to your target in one line instead of doins multiple variable assignment
sheets(clista).Rows(sheets(clista).Cells(Rows.Count, 1).End(xlUp).Row +1).value = .Rows(x)value
sheets(clista).Rows(1).value = .Rows(1)value
Sub Search()
'Macro
Application.ScreenUpdating = False
Hey guys,
I keep getting a typed mismatch when I look for a range within column "U"
"It gets stuck on If Cells(x, "U") = MyVars Then" and I don't know what I'm doing wrong.
Any help is greatly appreciated.
Dim copysheet As Worksheet
Dim pastesheet As Worksheet
Dim MyVars As Range
Dim Myline As Range
Set copysheet = Worksheets("RawData")
Set pastesheet = Worksheets("SEARCH")
Set MyVars = copysheet.Range("$Y$1")
pastesheet.Select
pastesheet.Range("$A$12:$Q$5000").ClearContents
'Search According to criteria
Dim x As Long
copysheet.Select
With copysheet.Range("U:U")
For x = 2 To 15000
If Cells(x, "U") = MyVars Then
Cells(x, "A").Resize(, 24).Copy
Application.ScreenUpdating = True
pastesheet.Cells(Rows.Count, "A").End(xlUp).Offset(1).PasteSpecial xlPasteFormulasAndNumberFormats
End If
Next x
End With
pastesheet.Select
Range("$B$6").Select
Beep
MsgBox "Search Complete"
End Sub
You've probably got an error value somewhere in column U that causing the type mismatch.
Try using this instead:
If copysheet.Cells(x, "U").Text = MyVars.Text Then
Btw, you've got the With copysheet.Range("U:U") ... End With lines but you are not actually making use of the With.
This is how I would fix your type mismatch and make your code more efficient. Using With to pre-qualify objects and For Each loops helps over the For x = # to # loop like you used before. Let me know if this doesn't work for you.
Sub Search()
'Macro
Application.ScreenUpdating = False
Dim copysheet As Worksheet
Dim pastesheet As Worksheet
Dim MyVars As Range
Dim Myline As Range
Dim MyRange As Range
Set copysheet = Worksheets("RawData")
Set pastesheet = Worksheets("SEARCH")
Set MyVars = copysheet.Range("$Y$1")
pastesheet.Range("$A$12:$Q$5000").ClearContents
'Search According to criteria
With copysheet
Set MyRange = .Range(.Cells(2, 21), .Cells(15000, 21))
For Each Myline in MyRange
If Myline.Value = MyVars Then
.Range(.Cells(Myline.Row, 1), .Cells(Myline.Row, 24)).Copy pastesheet.Cells(Rows.Count, 1).End(xlUp).Offset(1).PasteSpecial xlPasteFormulasAndNumberFormats
End If
Next Myline
End With
pastesheet.Activate
Range("$B$6").Select
Beep
MsgBox "Search Complete"
Application.ScreenUpdating = True
End Sub
Hey have a quick question I am writing a code that hides a list of worksheets based on whether the field next to the worksheet name is yes or no. Therefore, I have list of 29 worksheets, I want my code to look at the field next to that name, and if its yes it while show it and if it is no It will hide it.
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim ws As Worksheet
For Each ws In Worksheets
If ws.Name = Worksheets("Settings").Range("B4:B32") _
And Worksheets("Setting").Range("C4:C32") = "Yes" Then
ws.Visible = True
End If
If ws.Name = Worksheets("Settings").Range("B4:B32") _
And Worksheets("Setting").Range("C4:C32") = "No" Then
ws.Visible = True
End If
Next ws
End Sub
I run this and keep getting a mismatch error i am new to programming so i don't think i am calling stuff correctly
I believe the following code should suit your needs:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim wsSettings As Worksheet
Dim wsHideShow As Worksheet
Dim rngSheets As Range
Dim xlCell As Range
Dim sheetName As String
Set wsSettings = ThisWorkbook.Worksheets("Settings")
Set rngSheets = wsSettings.Range("B4:B32")
For Each xlCell In rngSheets
sheetName = xlCell.Value
If sheetName <> "" Then
Set wsHideShow = ThisWorkbook.Worksheets(sheetName)
If xlCell.Offset(0, 1).Value = "yes" Then
wsHideShow.Visible = False
Else
wsHideShow.Visible = True
End If
End If
Next xlCell
End Sub
Instead of looping through your worksheets, loop through your list and hide/show the worksheets accordingly.
This code runs in a standard module. It assumes that the master is Settings rather than Setting
It loops over the table as well as the sheets:
Sub DisplayOrHideSheets()
Dim sh As Worksheet
For Each ws In Sheets
v = ws.Name
For Each r In Worksheets("Settings").Range("B4:B32")
If r.Value = v Then
If r.Offset(0, 1) = "Yes" Then
ws.Visible = True
Else
ws.Visible = False
End If
End If
Next r
Next ws
End Sub
Being slow in typing... but... my suggestion would be:
Private Sub WorkSheet_Change(ByVal Target as range)
If (Target.Row >= 4 And Target.Row <= 32 And Target.Column = 2) Then
Dim i as Integer
For i=0 To 28 Step 1
If Range("B" & 2 + i).Value = "YES" Then
ThisWorkBook.Worksheets(Range("A" & 2 + i).Value).Visible = True
Else
ThisWorkBook.Worksheets(Range("A" & 2 + i).Value).Visible = False
End If
Next i
End If
End Sub
This is fireing only when the values in the range B4:B32 on the sheet are changed...
Hope this helps...