I believe I have everything else figured out but the line Set newSheetName = sht.Range("A1:A") is not pulling any information. I am getting the Run-time error '1004': Method 'Range' of object'_Worksheet' failed. What am I missing?
What I am trying to achieve is for this macro to look at the range in sheet "ARK_E_TEXAS" which is A1 through C23("ARK_E_TEXAS_LIST"). If A1:A has data it will create a new sheet and name that new sheet with the cell name. I am using the Lastrow line to know how many lines to go down and the if function to skip over the blanks.
Sub Create_ARK_E_TEXAS()
Dim sht As Worksheet
Dim newSheetName As Range
Dim dataRange As Range
Dim Lastrow As Long
Set sht = ThisWorkbook.Sheets("ARK_E_TEXAS")
Set newSheetName = sht.Range("A1:A")
Lastrow = sht.Range("ARK_E_TEXAS_LIST").Rows.Count
Set dataRange = sht.Range("A1:C" & Lastrow)
For Each newSheetName In dataRange
If newSheetName.Value <> "" Then
Sheets.Add After:=Sheets(Sheets.Count) 'creates a new worksheet
Sheets(Sheets.Count).Name = newSheetName.Value ' renames the new worksheet
End If
Next newSheetName
End Sub
Ok I got my answer with the help of #AlexWeber.
Sub Create_ARK_E_TEXAS()
Dim sht As Worksheet
Dim newSheetName As Range
Dim dataRange As Range
Dim Lastrow As Long
Set sht = ThisWorkbook.Sheets("ARK_E_TEXAS")
Lastrow = sht.Range("ARK_E_TEXAS_LIST").Rows.Count
Set newSheetName = sht.Range("A1:A" & Lastrow)
Set dataRange = sht.Range("A1:A" & Lastrow)
For Each newSheetName In dataRange
If newSheetName.Value <> "" Then
Sheets.Add After:=Sheets(Sheets.Count) 'creates a new worksheet
Sheets(Sheets.Count).Name = newSheetName.Value ' renames the new worksheet
End If
Next newSheetName
End Sub
Related
Trying to loop though the worksheets to apply the filter on date, and copy all the filtered data into a "Report" sheet.
Here is code, which loops only the first sheet ( USD) and not the second one (EUR).
Sub SheetLoop()
Dim Ws As Worksheet
Dim wb As Workbook
Dim DestSh As Worksheet
Dim Rng As Range
Dim CRng As Range
Dim DRng As Range
Set wb = ThisWorkbook
Set DestSh = wb.Worksheets("Report")
Set CRng = DestSh.Range("L1").CurrentRegion
Set DRng = DestSh.Range("A3")
For Each Ws In wb.Worksheets
If Ws.Name <> DestSh.Name Then
Set Rng = Ws.Range("A1").CurrentRegion
Rng.AdvancedFilter xlFilterCopy, CRng, DRng
End If
Next Ws
End Sub
Since AdvancedFilter needs the filtered range headers, you cannot copy only part of the filtered range, but you can delete the first row of the copied range, except the first copied range (from first sheet):
Sub SheetLoop()
Dim Ws As Worksheet, wb As Workbook, DestSh As Worksheet
Dim Rng As Range, CRng As Range, DRng As Range, i As Long
Set wb = ThisWorkbook
Set DestSh = wb.Worksheets("Report")
Set CRng = DestSh.Range("L1").CurrentRegion
Set DRng = DestSh.Range("A3")
For Each Ws In wb.Worksheets
If Ws.name <> DestSh.name Then
i = i + 1
Set Rng = Ws.Range("A1").CurrentRegion
Rng.AdvancedFilter xlFilterCopy, CRng, DRng
If i > 1 Then DRng.cells(1).EntireRow.Delete xlUp 'delete the first row of the copied range, except the first case
Set DRng = DestSh.Range("A" & DestSh.rows.count).End(xlUp).Offset(1) 'reset the range where copying to
End If
Next Ws
MsgBox "Ready..."
End Sub
I have around 30 sheets that I want this code to run in at the same time. I want to find "ABC" and delete the value of the cell next to it in all my worksheets.
I get my error from: Set rSearch = .**range**("A1", .range("A" & rows.count).end(x1up))
When I have specified "Sheet1" next to the "With" statement, it works, but I want this code to run on all my sheets.
Sub soek()
Dim rSearch As Range
Dim rFound As Range
Dim sign12 As String
Dim sheetsarray As Sheets
Set sheetsarray = ActiveWorkbook.Sheets(Array("sheet1", "sheet2", "sheet3"))
sign12 = "ABC"
With sheetsarray
Set rSearch = .Range("A1", .Range("A" & Rows.Count).End(xlUp))
Set rFound = rSearch.Find(What:=sign12, LookIn:=xlValues)
If rFound Is Nothing Then
Else
rFound.Offset(0, 1).ClearContents
End If
End With
End Sub
This question is a lot like: How to search for a string in all sheets of an Excel workbook?
But in my opinion, it's a lot easier to understand how to make code run on additional sheets reading my code than the code from the link above.
Try this (compilation of the comments above ;-)
Sub soek()
Dim rSearch As Range
Dim rFound As Range
Dim sign12 As String
Dim oWB As Workbook
Dim oWS As Worksheet
Set oWB = ThisWorkbook
sign12 = "ABC"
For Each oWS In oWB.Sheets
With oWS
Set rSearch = .Range("A1", .Range("A" & Rows.Count).End(xlUp))
Set rFound = rSearch.Find(What:=sign12, LookIn:=xlValues)
If rFound Is Nothing Then
Else
rFound.Offset(0, 1).ClearContents
End If
End With
Next oWS
End Sub
I am trying to cycle through all worksheets apart from one called 'summary', looking down a range in column A until finding a value, then looking in another workbook and getting some data, pasting it in, then carrying on until the end of column A range. Then it should move onto the next worksheet and repeat the process. I have been able to execute the code within the loop successfully, but only on the active worksheet. I've tried various iterations of the 'for each' statements. The current way seems to loop through the worksheets but doesn't run the code.
How can i amend it so it works properly?
Sub GetFlows()
Dim rng As Range
Dim row As Range
Dim cell As Range
Dim dem1 As String
Dim WhereCell As Range
Dim ws As Excel.Worksheet
Dim iIndex As Integer
Dim valueRng As Range
Dim x As Long
Dim y As Long
Set rng = Range("A9:A200")
For Each ws In ThisWorkbook.Worksheets
If ws.Name <> "summary" Then
ws.Activate
For x = 1 To rng.Rows.Count
dem1 = rng.Cells(x).Value
If dem1 <> "" Then
Set WhereCell = ThisWorkbook.ActiveSheet.Range("A9:A200").Find(dem1, lookat:=xlPart)
Windows("GetFilenames v2.xlsm").Activate
Worksheets(dem1).Range("A1").CurrentRegion.Copy
WhereCell.Offset(, 2).PasteSpecial Paste:=xlPasteValues
Else
ThisWorkbook.Activate
End If
Next x
End If
Next ws
End Sub
You could avoid all the Activate and Select and qualify all your Range and Cells statemets inside by using With ws.
So after you loop through all your Worksheets in :
For Each ws In ThisWorkbook.Worksheets , you add With ws and all the objects inside are qualified with the ws object.
Code:
Option Explicit
Sub GetFlows()
Dim cell As Range
Dim dem1 As String
Dim WhereCell As Range
Dim ws As Worksheet
Dim valueRng As Range
Dim x As Long
Dim y As Long
For Each ws In ThisWorkbook.Worksheets
With ws
If .Name <> "summary" Then
For x = 9 To 200 ' run a loop from row 9 to 200
dem1 = .Range("A" & x).Value
If dem1 <> "" Then
Set WhereCell = .Range("A9:A200").Find(what:=dem1, LookAt:=xlPart)
If Not WhereCell Is Nothing Then
Workbooks("GetFilenames v2.xlsm").Worksheets(dem1).Range("A1").CurrentRegion.Copy
WhereCell.Offset(, 2).PasteSpecial xlPasteValues
End If
End If
Next x
End If
End With
Next ws
End Sub
Can you try this? This checks if the value is found.
Sub GetFlows()
Dim rng As Range
Dim row As Range
Dim cell As Range
Dim dem1 As String
Dim WhereCell As Range
Dim ws As Excel.Worksheet
Dim iIndex As Integer
Dim valueRng As Range
Dim x As Long
Dim y As Long
Set rng = Range("A9:A200") ' should specify a sheet here, presumably Summary?
For Each ws In ThisWorkbook.Worksheets
If ws.Name <> "summary" Then
For x = 1 To rng.Rows.Count
dem1 = rng.Cells(x).Value
If dem1 <> vbNullString Then
Set WhereCell = ws.Range("A9:A200").Find(dem1, lookat:=xlPart)
If Not WhereCell Is Nothing Then
Workbooks("GetFilenames v2.xlsm").Worksheets(dem1).Range("A1").CurrentRegion.Copy
WhereCell.Offset(, 2).PasteSpecial Paste:=xlPasteValues
End If
End If
Next x
End If
Next ws
End Sub
I have this code that loops all the sheets in my workbook and need to skip some of the sheets that will be hidden in my workbook by their codename
This is the code im using.
Dim WS As Worksheet
For Each WS In Worksheets
'Skips sheets below
example Skip .sheetscodename, .sheetscodename2, and so on
'Insert code to be looped here
Set Rng = WS.Range("C7", WS.Range("C1048576").End(xlUp))
For Each cel In Rng
If cel.Value = "0" Then
cel.EntireRow.Hidden = True
End If
Next cel
'Next sheet
Next WS
One method is to create a string of all the names to be skipped, then use InStr():
Dim WS As Worksheet
Dim cel As Range, Rng As Range
Dim shts As String
shts = ("sheetscodename,sheetscodename2,...")
For Each WS In Worksheets
If InStr(1, shts & ",", WS.CodeName & ",", vbTextCompare) = 0 Then
'Insert code to be looped here
Set Rng = WS.Range("C7", WS.Range("C1048576").End(xlUp))
For Each cel In Rng
If cel.Value = "0" Then
cel.EntireRow.Hidden = True
End If
Next cel
End If
'Next sheet
Next WS
This code does what I want per entry in the txtKB textbox:
Dim ws1 As Worksheet
Dim lastrow As Long
Dim clipboardObj As New MSForms.DataObject
Dim wstest As Worksheet
Dim clipboardTxt As String
Set ws1 = Sheets("Sheet6")
Set wstest = Sheets("Sheet8")
lastrow = ws1.Range("A" & Rows.Count).End(xlUp).Row
ws1.Range("M1:A" & lastrow).AutoFilter field:=13, Criteria1:=txtKB
ws1.Range("B" & Rows.Count).End(xlUp).Offset(1).Select
txtmedian = WorksheetFunction.Aggregate(12, 5, Columns(2))
clipboardTxt = txtmedian.Text
clipboardObj.SetText clipboardTxt
clipboardObj.PutInClipboard
wstest.Range("A" & Rows.Count).End(xlUp).Offset(1) = txtmedian
but I want to improve it (so that I will not need to manually input the ID in textbox txtKB criteria anymore, and automate everything with just one click of a button) to take an entry in ws2 Column A (like an ID), look it up in ws1 then perform the median extraction, paste the median in wstest then move to the next ID in ws2 until it goes through all IDs in ws2.
Note: ws2 is not yet in the code.
I need to place a loop somewhere I just don't know where.
You could try something like:
Dim ws as worksheet
Dim wb as workbook
set wb = ThisWorkbook
For Each ws in wb.Worksheets
' Do what you want here
next ws
This will loop through all worksheets in the workbook
To work it into your code
Dim wb as workbook
Dim ws As Worksheet
Dim lastrow As Long
Dim clipboardObj As New MSForms.DataObject
Dim wstest As Worksheet
Dim clipboardTxt As String
set wb = ThisWorkbook
Set wstest = Sheets("Sheet8")
For Each ws in wb.Worksheets ' Loop through all sheets in workbook
if not ws.name = wstest.name then ' Avoid sheet you're copying too (ammend as needed)
With ws
lastrow = .Range("A" & Rows.Count).End(xlUp).Row
.Range("M1:A" & lastrow).AutoFilter field:=13, Criteria1:=txtKB
.Range("B" & Rows.Count).End(xlUp).Offset(1).Select
End With
txtmedian = WorksheetFunction.Aggregate(12, 5, Columns(2))
clipboardTxt = txtmedian.Text
clipboardObj.SetText clipboardTxt
clipboardObj.PutInClipboard
wstest.Range("A" & Rows.Count).End(xlUp).Offset(1) = txtmedian 'You will need to change your code to paste into different locations I would have assumed, I'll leave that up to you though
End if
Next ws