How can I change this code so it runs on all sheets of a workbook? It works well, just need it to run on all sheets. =)
Option Explicit
Option Compare Text
Sub HideColumns()
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Data")
Dim MyCell As Range
Dim HideMe As Range
Application.ScreenUpdating = False
For Each MyCell In ws.Range("A2:EA2")
If MyCell <> "First Name" And MyCell <> "Age" And MyCell <> "Gender" Then
If HideMe Is Nothing Then
Set HideMe = MyCell
Else
Set HideMe = Union(HideMe, MyCell)
End If
End If
Next MyCell
If Not HideMe Is Nothing Then
HideMe.EntireColumn.Hidden = True
End If
Application.ScreenUpdating = True
End Sub
Loop through sheets using For Each loop & reset HideMe to Nothing before moving to next sheet.
Option Explicit
Option Compare Text
Sub HideColumns()
Dim ws As Worksheet 'Change made here
Dim MyCell As Range
Dim HideMe As Range
Application.ScreenUpdating = False
For Each ws in Worksheets 'and here
For Each MyCell In ws.Range("A2:EA2")
If MyCell <> "First Name" And MyCell <> "Age" And MyCell <> "Gender" Then
If HideMe Is Nothing Then
Set HideMe = MyCell
Else
Set HideMe = Union(HideMe, MyCell)
End If
End If
Next MyCell
If Not HideMe Is Nothing Then
HideMe.EntireColumn.Hidden = True
End If
Set HideMe = Nothing 'and here
Next ws 'and here
Application.ScreenUpdating = True
End Sub
Related
I am trying to create user form (like on picture) from where I would choose 2 excel files and execute Vlookup. I
I try this code but it does not execute Vlookup.
xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
Option Explicit
Dim FileToOpen1 As Variant
Dim FileToOpen2 As Variant
Dim wb1 As Workbook
Dim wb2 As Workbook
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim rng1 As Range
Dim rng2 As Range
Dim cl As Range
Private Sub BrowseButton1_Click()
FileToOpen1 = Application.GetOpenFilename(Title:="Browse for your file", FileFilter:="Excel Files(*.xls*),*xls*")
If FileToOpen1 <> False Then
TextBox1 = FileToOpen1
End If
End Sub
Private Sub BrowseButton2_Click()
FileToOpen2 = Application.GetOpenFilename(Title:="Browse foy your file", FileFilter:="Excel Files(*.xls*),*xls*")
If FileToOpen2 <> False Then
TextBox2 = FileToOpen2
End If
End Sub
Private Sub OK_Click()
If FileToOpen1 <> False Then
Set wb1 = Application.Workbooks.Open(FileToOpen1)
End If
If FileToOpen2 <> False Then
Set wb2 = Application.Workbooks.Open(FileToOpen2)
End If
On Error Resume Next
rng1 = wb1.Sheets(1).Range("B3:B8")
Price_row = wb1.Sheets(1).Range("C3").row
Price_clm = wb1.Sheets(1).Range("C3").column
rng2 = wb2.Sheets(1).Range("A3:C8")
For Each cl In rng1
wb1.Sheets(1).Cells(Price_row, Price_clm) = Application.WorksheetFunction.VLOOKUP(cl, rng2, 2, False)
Price_row = Price_row + 1
Next cl
End Sub
You are missing two variable definitions:
Dim Price_row As Long
Dim Price_clm As Long
And variables for range need to be assigned with Set
This: Set rng2 = wb2.Sheets(1).Range("A3:C8") instead of this rng2 = wb2.Sheets(1).Range("A3:C8")
Now, vlookup function in vba will throw an error when it doesnt find a value.
A workaround for this will be something like this.
Private Sub OK_Click()
If FileToOpen1 <> False Then
Set wb1 = Application.Workbooks.Open(FileToOpen1)
End If
If FileToOpen2 <> False Then
Set wb2 = Application.Workbooks.Open(FileToOpen2)
End If
Set rng1 = wb1.Sheets(1).Range("B3:B8")
Price_row = wb1.Sheets(1).Range("C3").Row
Price_clm = wb1.Sheets(1).Range("C3").Column
Set rng2 = wb2.Sheets(1).Range("A3:C8")
For Each cl In rng1
On Error Resume Next
vlResult = "" 'Reset variable
vlResult = Application.WorksheetFunction.VLookup(cl, rng2, 2, False) 'Performs vlookup
If Not vlResult = "" Then
wb1.Sheets(1).Cells(Price_row, Price_clm).Value = vlResult
Else
wb1.Sheets(1).Cells(Price_row, Price_clm).Value = "N/A"
End If
Price_row = Price_row + 1
Next cl
End Sub
*Dont forget to add the variable too.
Dim vlResult As String
I am new to VBA and this is the first Macro I've tried to write.
I have an excel table which has five columns titled Address, location , works , action and completed. I want to create a new worksheet for each unique address and then copy the relevant rows for that address on that new worksheet. However, I only want to copy and paste the unique rows if the value in "Completed" is "N". The Value in completed can only be "Y" or "N".
Here is the code I have written:
Dim AddressField As Range
Dim AddressName As Range
Dim CompletedField As Range
Dim NewWSheet As Worksheet
Dim WSheet As Worksheet
Dim WSheetFound As Boolean
Dim DataWSheet As Worksheet
Set DataWSheet = Worksheets("Data")
Set AddressField = DataWSheet.Range("A4", DataWSheet.Range("A4").End(xlDown))
Set CompletedField = DataWSheet.Range("E4", DataWSheet.Range("E4").End(xlDown))
Application.ScreenUpdating = False
For Each AddressName In AddressField
For Each WSheet In ThisWorkbook.Worksheets
If CompletedField = "No" Then
If WSheet.Name = AddressName Then
WSheetFound = True
Exit For
Else
WSheetFound = False ' if it doesn't assign False to the WSheetFound variable
End If
Next WSheet
If WSheetFound Then 'if WSheetFound = True
AddressName.Offset(0, 0).Resize(1, 5).Copy Destination:=Worksheets(AddressName.Value).Range("A3").End(xlDown).Offset(1, 0)
Else 'if WSheetFound = False
Set NewWSheet = Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
NewWSheet.Name = AddressName
DataWSheet.Range("A3", DataWSheet.Range("A3").End(xlToRight)).Copy Destination:=NewWSheet.Range("A3")
AddressName.Offset(0, 0).Resize(1, 5).Copy Destination:=NewWSheet.Range("A4")
End If
Next AddressName
For Each WSheet In ThisWorkbook.Worksheets
WSheet.UsedRange.Columns.AutoFit
Next WSheet
Application.ScreenUpdating = True
End Sub
I keep getting the "Next without For" error when I try to run the code. I think it has something to do with the "IF CompletedField = "N" line, but not sure how to fix it !
Any help would be greatly appreciated
Try this:
Sub CopyRows()
Dim c As Range, ws As Worksheet, DataWSheet As Worksheet, wb As Workbook
Set wb = ThisWorkbook
Set DataWSheet = wb.Worksheets("Data")
Application.ScreenUpdating = False
For Each c In DataWSheet.Range("A4", DataWSheet.Range("A4").End(xlDown)).Cells
If c.EntireRow.Columns("E").Value = "No" Then
Set ws = Nothing
On Error Resume Next 'ignore any error on next line
Set ws = wb.Worksheets(c.Value) 'try to get the sheet
On Error GoTo 0 'stop ignoring errors
If ws Is Nothing Then 'was sheet found?
Set ws = wb.Worksheets.Add(after:=wb.Worksheets(wb.Worksheets.Count))
DataWSheet.Rows(3).Copy ws.Range("A3") 'copy headers
ws.Name = c.Value 'name the sheet
End If
c.Resize(1, 5).Copy ws.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
End If
Next c
For Each ws In wb.Worksheets
ws.UsedRange.Columns.AutoFit
Next ws
Application.ScreenUpdating = True
End Sub
Check the Completed column before deciding if a sheet needs to be created or not.
Update - Added copy for A1,A2,D2
Sub test()
Dim AddressField As Range, AddressName As Range, CompletedField As Range
Dim NewWSheet As Worksheet, WSheet As Worksheet, DataWSheet As Worksheet
Dim WSheetFound As Boolean
Set DataWSheet = Worksheets("Data")
Set AddressField = DataWSheet.Range("A4", DataWSheet.Range("A4").End(xlDown))
'Set CompletedField = DataWSheet.Range("E4", DataWSheet.Range("E4").End(xlDown))
Application.ScreenUpdating = False
For Each AddressName In AddressField
If AddressName.Cells(1, 5) = "No" Then ' col E
For Each WSheet In ThisWorkbook.Worksheets
If WSheet.Name = AddressName.Value2 Then
WSheetFound = True
Exit For
Else
WSheetFound = False ' if it doesn't assign False to the WSheetFound variable
End If
Next WSheet
If WSheetFound Then 'if WSheetFound = True
AddressName.Offset(0, 0).Resize(1, 5).Copy _
Destination:=Worksheets(AddressName.Value).Range("A3").End(xlDown).Offset(1, 0)
Else 'if WSheetFound = False
Set NewWSheet = Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
NewWSheet.Name = AddressName
DataWSheet.Range("A1:A2").Copy NewWSheet.Range("A1")
DataWSheet.Range("D2").Copy NewWSheet.Range("D2")
DataWSheet.Range("A3", DataWSheet.Range("A3").End(xlToRight)).Copy _
Destination:=NewWSheet.Range("A3")
AddressName.Offset(0, 0).Resize(1, 5).Copy Destination:=NewWSheet.Range("A4")
End If
End If
Next AddressName
For Each WSheet In ThisWorkbook.Worksheets
WSheet.UsedRange.Columns.AutoFit
Next WSheet
Application.ScreenUpdating = True
End Sub
I have a code that builds up and selects the range to copy it over to another worksheet in another sub.
Sub SelectREZ()
'Disable screen update
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'Declare variables
Dim c As Range, ws As Worksheet
Dim rngG As Range, lastJ, rngJ As Range
Set ws = ActiveSheet
For Each c In Intersect(ws.UsedRange, ws.Columns("C"))
Set rngJ = c.EntireRow.Columns("J")
If c = "REZ" Then
AddRange rngG, c.EntireRow
'Remember the "ITEM NO."
lastJ = rngJ.Value
Else
If Len(lastJ) > 0 Then
If rngJ.Value Like lastJ & "*" Then
AddRange rngG, c.EntireRow
Else
lastJ = ""
End If
End If
End If
Next c
rngG.Select
End Sub
'Utility sub for building up a range
Sub AddRange(rngTot As Range, rngAdd As Range)
If rngTot Is Nothing Then
Set rngTot = rngAdd
Else
Set rngTot = Application.Union(rngTot, rngAdd)
End If
'Disable screen update
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
And I've ran into a situation when the range is empty and macro dies on the line
rngG.Select
How do I prevent such macro crash and quit the sub if range to select is empty?
I mean I could do:
On Error Resume Next
rngG.Select
But it seems like a sledgehammer way to approach it.
I try to get a number copied from one list in one sheet to a new created sheet in specific cell. The code first check if there already exist a sheet with this name, if not it creates a new sheet and then add it and paste in a table from another sheet. After this is done I also want a number to be filled in from the list but I dont get it to work with FOR EACH as i did with first one. I really don't know how i shall do it? Im trying to get the inum to be written in each new sheet.
`Sub Sample()
Dim ws As Worksheet
Dim Row As Long
Dim inu As Long
Dim i As Long
'~~> Set this to the relevant worksheet
Set ws = Sheets("Röd")
Set wsi = Sheets("Röd")
With ws
'~~> Find last row in Column A
Row = .Range("A" & .Rows.Count).End(xlUp).Row
With wsi
inu = .Range("B" & .Rows.Count).End(xlUp).Row
'~~> Loop through the range
For i = 3 To Row
'~~> Check if cell is not empty
If Len(Trim(.Range("A" & i).Value2)) <> 0 Then
'~~> Whatever this fuction does. I am guessing it
'~~> checks if the sheet already doesn't exist
If SheetCheck(.Range("A" & i)) = False Then
With ThisWorkbook
'~~> Add the sheet
.Sheets.Add After:=.Sheets(.Sheets.Count)
'~~> Color the tab
.Sheets(.Sheets.Count).Tab.Color = RGB(255, 0, 0)
'~~> Name the tab
.Sheets(.Sheets.Count).Name = Left(ws.Range("A" & i).Value2, 30)
Sheets("Utredningsmall").Range("A1:B22").Copy Destination:=Sheets(Sheets.Count).Range("A1")
.Sheets(.Sheets.Count).Range("B4").Value = ws.Range("A" & i).Value
Columns("A:B").AutoFit
Rows("1:25").AutoFit
For j = 3 To inu
'If Len(Trim(Range("B" & inu).Value2)) <> 0 Then
Sheets(Sheets.Count).Range("B3").Value2 = wsi.Range("B" & j).Value2
'End If
Next j
End With
End If
End If
Next i
End With
End With
End Sub`
Create Worksheets from List
Option Explicit
Sub createWorksheets()
Dim wb As Workbook: Set wb = ThisWorkbook ' Workbook containing this code.
Dim MyRange As Range
With wb.Worksheets("Röd").Range("A3")
Set MyRange = .Resize(.Worksheet.Cells(.Worksheet.Rows.Count, .Column) _
.End(xlUp).Row - .Row + 1)
End With
Application.ScreenUpdating = False
Dim MyCell As Range
For Each MyCell In MyRange.Cells
If Len(MyCell) > 0 Then
If Not SheetCheck(wb, MyCell.Value) Then
With wb.Worksheets.Add(After:=wb.Sheets(wb.Sheets.Count))
' Data
wb.Worksheets("Utredningsmall").Range("A1:B22").Copy _
Destination:=.Range("A1")
.Range("B3").Value = MyCell.Offset(, 1).Value
.Range("B4").Value = MyCell.Value
.Name = Left(MyCell.Value, 30)
' Formats
.Tab.Color = RGB(255, 0, 0)
.Columns("A:B").AutoFit
.Rows("1:25").AutoFit
End With
End If
End If
Next MyCell
Application.ScreenUpdating = True
End Sub
Function SheetCheck( _
wb As Workbook, _
ByVal SheetName As String) _
As Boolean
On Error Resume Next
Dim sh As Object: Set sh = wb.Sheets(SheetName)
On Error GoTo 0
SheetCheck = Not sh Is Nothing
End Function
Sub Röd()
Dim MyCell As Range, MyRange As Range
Dim ws As Worksheets
Dim inum As Range, Myinum As Range
'This Macro will create separate tabs based on a list in Distribution Tab A3, B3 down
Set MyRange = Sheets("Röd").Range("A3")
Set MyRange = Range(MyRange, MyRange.End(xlDown))
Application.DisplayAlerts = False
For Each MyCell In MyRange
If SheetCheck(MyCell) = False And MyCell <> "" Then
Sheets.Add After:=Sheets(Sheets.Count) 'creates a new worksheet
Sheets(Sheets.Count).Tab.Color = RGB(255, 0, 0)
Sheets(Sheets.Count).Name = Left(MyCell.Value2, 30) ' renames the new worksheet
Sheets("Utredningsmall").Range("A1:B22").Copy Destination:=Sheets(Sheets.Count).Range("A1")
Sheets(Sheets.Count).Range("B4").Value = MyCell.Value2
Sheets(Sheets.Count).Range("B3").Value = MyCell.Offset(, 1).Value
Columns("A:B").AutoFit
Rows("1:25").AutoFit
End If
Next
Application.DisplayAlerts = True
End Sub
OR
Sub Röd()
Dim MyCell As Range, MyRange As Range
Dim ws As Worksheets
Dim inum As Range, Myinum As Range
'This Macro will create separate tabs based on a list in Distribution Tab A3, B3 down
Set MyRange = Sheets("Röd").Range("A3")
Set MyRange = Range(MyRange, MyRange.End(xlDown))
Application.DisplayAlerts = False
For Each MyCell In MyRange
If SheetCheck(MyCell) = False And MyCell <> "" Then
Sheets.Add After:=Sheets(Sheets.Count) 'creates a new worksheet
Sheets(Sheets.Count).Tab.Color = RGB(255, 0, 0)
Sheets(Sheets.Count).Name = Left(MyCell.Value2, 30) ' renames the new worksheet
Sheets("Utredningsmall").Range("A1:B22").Copy Destination:=Sheets(Sheets.Count).Range("A1")
Sheets(Sheets.Count).Range("B4").Value = MyCell.Value2
Sheets(Sheets.Count).Range("B3").Value = MyCell.Offset(, 1).Value
Columns("A:B").AutoFit
Rows("1:25").AutoFit
End If
Next
Application.DisplayAlerts = True
End Sub
Function:
Function SheetCheck(MyCell As Range) As Boolean
Dim ws As Worksheet
SheetCheck = False
For Each ws In ThisWorkbook.Worksheets
If ws.Name = Left(MyCell.Value, 30) Then
SheetCheck = True
End If
Next
End Function
Both these codes works now. They go through a list and create a new sheet for each cell in the list.
I have some code here but I'd like it to skip worksheets names Aggregated, Collated Results, Template, End. I have tried to add an If statement in to skip these but it doesn't seem to like it.
Sub FillBlanks()
Dim ws As Worksheet
Dim rng1 As Range
Dim rng2 As Range
For Each ws In Worksheets
Set rng2 = ws.Range("L1:AB40")
On Error Resume Next
Set rng1 = rng2.SpecialCells(xlBlanks)
on error goto 0
if not rng1 is nothing then
Application.Iteration = True
rng1.FormulaR1C1 = "=AVERAGE(R[-1]C,R[1]C)"
Application.Iteration = False
rng2.Value = rng2.Value
end if
Next ws
End Sub
If you add the names of the sheets you want to skip to the line worksheetsToSkip = array("... (below), then the code below should skip said sheets.
Option Explicit
Sub FillBlanks()
Dim ws As Worksheet
Dim rng1 As Range
Dim rng2 As Range
Dim worksheetsToSkip As Variant
worksheetsToSkip = Array("Aggregated", "Collated Results", "Template", "End")
For Each ws In Worksheets
If IsError(Application.Match(ws.Name, worksheetsToSkip, 0)) Then
Set rng2 = ws.Range("L1:AB40")
On Error Resume Next
Set rng1 = rng2.SpecialCells(xlBlanks)
On Error GoTo 0
If Not rng1 Is Nothing Then
Application.Iteration = True
rng1.FormulaR1C1 = "=AVERAGE(R[-1]C,R[1]C)"
Application.Iteration = False
rng2.Value = rng2.Value
End If
End If
Next ws
End Sub