I have sheet1, sheet2 , sheet3, sheet4.
Of the 4 Sheets, sheet 1 and sheet2 has data in list. and sheet3 and sheet 4 has Pivot tables for the same.
I would like to have a VBA, in such a way that, in my workbook, if it find Sheets with list, then it shoudl Format it to table. The table should be only for the cells it has value.
I used record macro, to get the code, but i am struck how i should implement it for all my Sheets.
the code, from record macro for one sheet:
sub macro()
Cells.Select
ActiveSheet.ListObjects.Add(xlSrcRange, Range("$1:$1048576"), , xlYes).Name = _
"Table2"
Cells.Select
ActiveSheet.ListObjects("Table2").TableStyle = "TableStyleLight9"
End Sub
I think you meant something like the code below:
Option Explicit
Sub macro()
Dim ws As Worksheet
Dim ListObj As ListObject
For Each ws In ThisWorkbook.Worksheets
With ws
For Each ListObj In .ListObjects
ListObj.TableStyle = "TableStyleLight9"
Next ListObj
End With
Next ws
End Sub
If your question is that change range to Listobject, look at follow code.
Sub macro()
Dim Ws As Worksheet
Dim LstObj As ListObject
Dim rngDB As Range, n As Integer
For Each Ws In Worksheets
With Ws
Set rngDB = .Range("a1").CurrentRegion
For Each LstObj In Ws.ListObjects
LstObj.Unlist
Next
If WorksheetFunction.CountA(rngDB) > 0 Then
n = n + 1
Set LstObj = .ListObjects.Add(xlSrcRange, rngDB, , xlYes)
With LstObj
.Name = "Table" & n
.TableStyle = "TableStyleLight9"
End With
End If
End With
Next Ws
End Sub
Related
I have data in Sheet1 in range A2:D17.
I want to copy this data & paste in various multiple sheets (count of sheets are 12).
Sub CopyData()
Dim ws As Worksheet
Dim wsStart As Worksheet
Set wsStart = Worksheets("Sheet1")
For Each ws In ThisWorkbook.Sheets
If Not ws.Name = wsStart.Name Then
wsStart.Range("A2:D17").Copy
ws.Range("A2").PasteSpecial (xlPasteAll)
End If
Next ws
End Sub
I'm trying to copy a column to the right of table and paste the formulas only (not values).
Sub acrescentaCols()
Dim oSheet As Worksheet
Set oSheet = Sheets("Sheet1")
oSheet.Columns("D:D").Select
Selection.Copy
Range(Selection, Selection.End(xlToRight)).Select
Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
End Sub
But this is copying also the values (because Excel considers values to be a formula too).
How do I fix this?
The below should fix your immediate problem of only copying the formulas across and not the values, but I'm not sure exactly what you're trying to do. If you can give more information I'm sure I can help you acheive what you're trying to get to.
It seems as if you want to copy the formulae to every row to the right of column D to the very right edge of the worksheet?
It also seems like you want to copy the formulae only so they re-evaluate in their new location - or do you want to past values only so that they hold the same values that they evaluated to in column D?
Anyway, give this a whirl.
Sub acrescentaCols()
Dim oSheet As Worksheet
Set oSheet = Sheets("Sheet1")
For Each cell In oSheet.Range("D1", Range("D1").End(xlDown))
If cell.HasFormula = True Then
cell.Copy
Range(cell.Address, Range(cell.Address).End(xlToRight)).PasteSpecial Paste:=xlPasteFormulas
End If
Next cell
End Sub
As per my comments earlier:
Sub acrescentaCols()
Dim oSheet As Worksheet
Dim rng As Range
Dim cel As Range
Set oSheet = Sheets("Sheet1")
With oSheet
Set rng = .Range(.Range("D1"), .Range("D" & .Rows.Count).End(xlUp))
For Each cel In rng
If Left(cel.Formula, 1) = "=" Then
Range(cel.Offset(, 1), cel.Offset(, 1).End(xlToRight)).Formular1c1 = cel.Formular1c1
End If
Next cel
End With
End Sub
When you say paste the formula only - your method will paste the formula and then recalculate and your formula will show the result. I think a better way to write that would be:
Sub acrescentaCols()
Dim oSheet As Worksheet
Dim rCopied As Range
Set oSheet = Sheets("Sheet1")
With oSheet
.Columns("D:D").Copy
Set rCopied = .Cells(1, 4).End(xlToRight).Offset(, 1).EntireColumn
rCopied.PasteSpecial Paste:=xlPasteFormulas
End With
End Sub
If you want to show the actual formula you could use a UDF something like:
Function GetFormula(Target As Range) As String
If Target.HasFormula Then
GetFormula = Target.Formula
End If
End Function
If you want to apply this to a whole column you could use:
Sub acrescentaCols1()
Dim oSheet As Worksheet
Dim rCopied As Range
Set oSheet = Sheets("Sheet1")
With oSheet
Set rCopied = .Cells(1, 4).End(xlToRight).Offset(, 1).EntireColumn
rCopied.FormulaR1C1 = "=GETFORMULA(RC4)"
End With
End Sub
This will probably kill your spreadsheet though - it will execute the UDF on all rows.
Sub acrescentaCols()
Dim oSheet As Worksheet, rng1 As Range, rng2 As Range, rng As Range
Set oSheet = Sheets("Sheet1")
Set rng1 = oSheet.Columns("D:D")
Set rng1 = Intersect(rng1, rng1.Worksheet.UsedRange) 'for the used range only
Set rng2 = Range(rng1, rng1.End(xlToRight))
For i = 1 To rng1.Cells.Count 'for each row
If Left(rng1(i, 1).Formula, 1) = "=" Then 'if it starts with an equal sign
For j = 1 To rng2.Columns.Count 'then for each column in the copy
rng2(i, j).FormulaR1C1 = rng1(i, 1).FormulaR1C1
Next j
End If
Next i
End Sub
I want to delete rows over multiple worksheets (only specific ones within the workbook) if a cell value is blank. Note, the rest of the fields in the row do contain data. So far I have the below however unsure how to specify the worksheets. Can anyone help?
Sub sbDelete_rows_if_cell_blank()
Dim lRow As Long
Dim iCntr As Long
lRow = 2000
For iCntr = lRow To 1 Step -1
If Cells(iCntr, 1).Value = "" Then
Rows(iCntr).Delete
End If
Next
End Sub
Putting your code inside this loop will loop through all the worksheets in the Workbook that this code is inside and run your code in each.
Sub sbDelete_rows_if_cell_blank()
Dim lRow As Long
Dim iCntr As Long
Dim ws as Worksheet
For each ws in ThisWorkbook.Worksheets
' Find last row in column A
lRow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
For iCntr = lRow To 1 Step -1
If ws.name<>"Sheet1" and ws.name <> "Sheet2" then ' change this line to the sheet names you want to leave out.
If IsEmpty(ws.Cells(iCntr, 1)) Or Trim(ws.Cells(iCntr, 1).Value) = "" Then
ws.Rows(iCntr).Delete
End If
end if
Next iCntr
Next ws
End Sub
Updated with D_Bester's suggestion for if condition
Update 2: See Comments
This will do what I think you want to achieve
Sub Combine()
Dim nws, ws As Worksheet
Dim rng As Range
' Add New Sheet
On Error Resume Next
Set nws = ThisWorkbook.Sheets("Combined")
If nws Is Nothing Then
With ThisWorkbook.Sheets
Set nws = .Add(After:=Sheets(.Count))
nws.Name = "Combined"
End With
End If
On Error GoTo 0
For Each ws In ThisWorkbook.Sheets
If Not ws.Name = nws.Name Then
With ws
Set rng = Range(.Cells(1, 1), .Cells(.UsedRange.Rows.Count, .UsedRange.Columns.Count))
rng.Copy Destination:=nws.Cells(nws.Cells(nws.Rows.Count, "A").End(xlUp).Row + 1, 1)
End With
End If
Next ws
End Sub
You can loop through the sheets, then use specialcells to delete the blanks.
Yoi can also set the loop so it doesn't delete the blanks in "Sheet1"(in this example)
Sub DeleteBlnkRows()
Dim sh As Worksheet
For Each sh In Sheets
If sh.Name <> "Sheet1" Then
sh.Columns("A:A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End If
Next sh
End Sub
I am having an issue creating a macro that will autofill a VBA function named "FindMyOrderNumber". Every time I run a macro to Autofill "FindMyOrderNumber" only the first cell in the column is populated.
This function will look up an order number in column A (A1) and return the name of the worksheet it can be found B (B1).
Option Explicit
Function FindMyOrderNumber(strOrder As String) As String
Dim ws As Worksheet
Dim rng As Range
For Each ws In Worksheets
If ws.CodeName <> "Sheet3" Then
Set rng = Nothing
On Error Resume Next
Set rng = ws.Cells.Find(What:=strOrder, LookAt:=xlWhole)
On Error GoTo 0
If Not rng Is Nothing Then
FindMyOrderNumber = ws.Name
Exit For
End If
End If
Next
Set rng = Nothing
Set ws = Nothing
End Function
I created this macro to enter my VBA function "=findmyordernumber(a1)" in cell B1 then to Autofill column B.
Sub AutofillVBAFunction()
Range("B1").Select
ActiveCell.FormulaR1C1 = "=FindMyOrderNumber(RC[-1])"
Selection.Autofill Destination:=Range("B1:B68")
Range("B1:B68").Select
End Sub
After I run this macro only B1 is populated.
Sorry if this has been discussed I am new and I tried How to fill-up cells within a Excel worksheet from a VBA function? and other questions and I could not apply it to my issue.
Please help
Add application.volatile to the function, that way it will calculate as the sheet changes.
Function FindMyOrderNumber(strOrder As String) As String
Dim ws As Worksheet
Dim rng As Range
Application.Volatile
For Each ws In Worksheets
If ws.CodeName <> "Sheet3" Then
Set rng = Nothing
On Error Resume Next
Set rng = ws.Cells.Find(What:=strOrder, LookAt:=xlWhole)
On Error GoTo 0
If Not rng Is Nothing Then
FindMyOrderNumber = ws.Name
Exit For
End If
End If
Next
Set rng = Nothing
Set ws = Nothing
End Function
It also wouldn't hurt to calculate the sheet when You add the formula to the range.
Sub Button1_Click()
Dim Rws As Long, Rng As Range
Rws = Cells(Rows.Count, "A").End(xlUp).Row
Set Rng = Range(Cells(1, 2), Cells(Rws, 2))
Rng = "=FindMyOrderNumber(RC[-1])"
End Sub
As the title I tried this one, but it overwrites existing data, I am looking for something that
add the header row in all sheets moving the data down. I have got 50 sheets that's why I am asking :-)
Sub CopyToAllSheets()
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("sheet1")
Sheets.FillAcrossSheets ws.Range("1:1")
End Sub
Thank you in advance
You could insert a line in each sheet before filling the headers:
Sub CopyToAllSheets()
Dim sheet As Worksheet
For Each sheet In Sheets
sheet.Rows("1:1").Insert Shift:=xlDown
Next sheet
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("sheet1")
Sheets.FillAcrossSheets ws.Range("1:1")
End Sub
I will be assuming that your header will be coming from another sheet. Recording a macro gives me:
Sub Macro4()
Sheets("Sheet1").Select
Rows("1:1").Select
Selection.Copy
Sheets("Sheet2").Select
Rows("1:1").Select
Selection.Insert Shift:=xlDown
Application.CutCopyMode = False
End Sub
Cleaning it up gives:
Sub InsertOnTop()
Sheets("Sheet1").Rows("1:1").Copy
Sheets("Sheet2").Rows("1:1").Insert Shift:=xlDown
Application.CutCopyMode = False
End Sub
Applying it safely across all sheets except the source sheet:
Sub InsertOnTopOfEachSheet()
Dim WS As Worksheet, Source As Worksheet
Set Source = ThisWorkbook.Sheets("Sheet1") 'Modify to suit.
Application.ScreenUpdating = False
For Each WS In ThisWorkbook.Worksheets
If WS.Name <> Source.Name Then
Source.Rows("1:1").Copy
WS.Rows("1:1").Insert Shift:=xlDown
End If
Next WS
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
Let us know if this helps.
I believe you will need to loop through each sheet and insert a blank row, or just use the range.insert method on each sheet. Perhaps something like:
Option Explicit
Sub CopyToAllSheets()
Dim WS As Worksheet
For Each WS In ThisWorkbook.Worksheets
If Not WS.Name = "Sheet1" Then
If WorksheetFunction.CountA(WS.Rows(1)) > 0 Then _
WS.Rows(1).Insert
End If
Next WS
Worksheets.FillAcrossSheets Worksheets("Sheet1").Rows(1), xlFillWithAll
End Sub