my VBA code is copy/pasting rows from several sheets in the workbook into another sheet based on a specific input criteria. It uses an InStr search to find the input criteria on sheets starting with "E" in column D between rows 17-50 - which is working good.
However, when activiting the sub through a button it only copy/pasts the first entry it finds and jumps to the next worksheet. In debug.mode it finds all entries in one worksheet, does copy/paste and only then jumps to the next worksheet.
What do I need to change?
Sub request_task_list()
Dim rPlacementCell As Range
Dim myValue As Variant
Dim i As Integer, icount As Integer
myValue = InputBox("Please enter the Name (Name or Surname) of the Person whos task you are looking for", "Input", "Hansen")
If myValue = "" Then
Exit Sub
Else
Set rPlacementCell = Worksheets("Collect_tool").Range("A3")
For Each Worksheet In ActiveWorkbook.Worksheets
'Only process if the sheet name starts with 'E'
If Left(Worksheet.Name, 1) = "E" Then
Worksheet.Select
For i = 17 To 50
If InStr(1, LCase(Range("D" & i)), LCase(myValue)) <> 0 Then
'In string search for input value from msg. box
'Copy the whole row if found to placement cell
icount = icount + 1
Rows(i).EntireRow.Copy
rPlacementCell.PasteSpecial xlPasteValuesAndNumberFormats
Range("D2").Copy
rPlacementCell.PasteSpecial xlPasteValues
Set rPlacementCell = rPlacementCell.Offset(1)
End If
Next i
End If
Next Worksheet
Worksheets("collect_tool").Activate
Range("B3").Activate
End If
End Sub
This code works for me:
Sub request_task_list()
Dim rPlacementCell As Range
Dim myValue As Variant
Dim i As Integer
Dim wrkBk As Workbook
Dim wrkSht As Worksheet
Set wrkBk = ActiveWorkbook
'or
'Set wrkBk = ThisWorkbook
'or
'Set wrkBk = Workbooks.Open("C:/abc/def/hij.xlsx")
myValue = InputBox("Please enter the Name (Name or Surname) of the Person whos task you are looking for", "Input", "Hansen")
If myValue <> "" Then
Set rPlacementCell = wrkBk.Worksheets("Collect_tool").Range("A3") 'Be specific about which workbook the sheet is in.
For Each wrkSht In wrkBk.Worksheets
'Only process if the sheet name starts with 'E'
If Left(wrkSht.Name, 1) = "E" Then
For i = 17 To 50
'Cells(i,4) is the same as Range("D" & i) - easier to work with numbers than letters in code.
If InStr(1, LCase(wrkSht.Cells(i, 4)), LCase(myValue)) > 0 Then 'Be specific about which sheet the range is on.
'In string search for input value from msg. box
'Copy the whole row if found to placement cell
wrkSht.Rows(i).EntireRow.Copy
rPlacementCell.PasteSpecial xlPasteValuesAndNumberFormats
rPlacementCell.Value = wrkSht.Cells(2, 4).Value
Set rPlacementCell = rPlacementCell.Offset(1)
End If
Next i
End If
Next wrkSht
Worksheets("collect_tool").Activate
Range("B3").Activate
End If
End Sub
I'm guessing your code failed at this point: For Each Worksheet In ActiveWorkbook.Worksheets. Worksheet is a member of the Worksheets collection and I don't think it can be used this way. Note in my code I've set wrkSht as a Worksheet object and then used wrkSht to reference the current worksheet in the loop.
Related
I'm trying to use VBA to run quick calculations on columns across multiple worksheets when a certain condition is met.
I need to get the count of marked cells within a column range over several worksheets where the worksheet's name begins with "BC" and have the results returned to a cell on another sheet.
Can someone help?
''Generating worksheets from list of values
Sub CreateTemplates()
Set Template = Sheets("Test New Format")
For Each cell in Range("lstbc")
If cell <> "" Then
Template.Copy After:=Sheets(4)
ActiveSheet.Name = "BC" & cell.Value
cell.Offset(0,1).Value = "BC" & cell
End If
Next
End Sub
''Loop through sheets that begin with BC & calculate count
Sub LoopSheets()
Dim wb As Workbook
Dim ws As Worksheet
Dim myTotal as Double
Dim ProcessNum as Integer
ProcessNum = 0
For Each wb in Workbooks
For Each ws in Worksheets
Debug.Print ws.Name
If InStr(1, Left(ws.Name,2), "BC", vbTextCompare) > 0 Then
myTotal = myTotal+1
ProcessNum = ProcessNum + Application.WorksheetFunction.CountA(Range("E9:E116"))
End If
Next ws
Next wb
Sheets("console").Range("c18").Value = ProcessNum
End Sub
I have 3 worksheets generated that contain "BC" in their name. The count from myTotal gives me 3 (that seems good), but when I try to get the count from the column range from each of those sheets, I don't get the correct results at all.
I am struggling to figure out how to get the code to do what I want, I wrote as much as I could with what I could find online, but for some aspects, I don't know what write.
Purpose of the code
Check "spreadsheet 2017" for the number "1" next to each name. If there is a "1", then enter values in multiple cells in a row in another workbook called "Dates template" (in the same row as name in "spreadsheet 2017")
Details on what I would like it to do
Column A and B has list first name (A), and surname (B)
Check through column C for "1", next to the names
If there is a 1, then switch to workbook "Dates Template"
find the same name in column A, and put the values 7.2 (col B), 3.9 (col C) and 74.2 (col D).
This is the basic backbone of the code, in the future I will be looking to add additional conditions, such as 1 in column D for example as well 1 in column C. so maybe a case function would work better, then it would be easier to add in the future. I don't know which is better.
In the code below I only wrote it to scan through the surnames in column B, because there are no duplicates. but in the future, it is likely that there will be names with the same surname, in which case first name will have to be read as well. This is where I'm confused on how to check both.
A bonus would be if its possible to copy the list of names over to the "Dates template" and then input those values if the criteria is met. Because at the moment I manually type up the names onto the "Date Template" Spreadsheet.
Sub Summary()
Dim wb1 As Workbook
Dim Sht As Worksheet
Dim Rng As Range
Dim wb2 As Workbook
Dim cell As Range
Dim ws As Worksheet
Set wb1 = Workbooks("Works template.xlsm")
Set wb2 = Workbooks("Spreadsheet 2017")
Set Sht = wb1.Worksheets("Template")
Set ws = wb2.Worksheets("January")
Set Rng = ws.Range("B7:B" & Sht.Cells(Sht.Rows.Count, "B").End(xlUp).Row)
For Each cell In Rng
If cell.Offset(0, 2).Value = "1" Then
Sht.Cells.Offset(0, 3).Value = "7.2" '<--- This is where I get the new error, "Application-defined or object-defined error"
Sht.Cells.Offset(0, 2).Value = "3.9"
Sht.Cells.Offset(0, 6).Value = "74.2"
End If
Next
End Sub
Thanks a lot!
Sht.Cells refers to all cells in the sheet, so you can't use .Offset() on this.
Sub Summary()
Dim wb1 As Workbook
Dim Sht As Worksheet
Dim Rng As Range
Dim wb2 As Workbook
Dim cell As Range
Dim ws As Worksheet
Set wb1 = Workbooks("Works template.xlsm")
Set wb2 = Workbooks("Spreadsheet 2017")
Set Sht = wb1.Worksheets("Template")
Set ws = wb2.Worksheets("January")
Set Rng = ws.Range("B7:B" & Sht.Cells(Sht.Rows.Count, "B").End(xlUp).Row)
For Each cell In Rng
If cell.Offset(0, 1).Value = "1" Then
sht.Range(cell.address).Offset(-2, 0).Offset(0, 0).Value = "7.2"
sht.Range(cell.address).Offset(-2, 0).Offset(0, 1).Value = "3.9"
sht.Range(cell.address).Offset(-2, 0).Offset(0, 2).Value = "74.2"
End If
Next
End Sub
Sub Insertdata()
Dim iAge As Integer
Set src = Workbooks.Open("age.xlsm", True, True)
t = 2
lastrow = ActiveSheet.UsedRange.Rows.Count
Do Until t = lastrow
iAge = src.Worksheets("Sheet1").Range("B" & t).Value
ThisWorkbook.Worksheets("Sheet1").Range("B" & t).Value = iAge
t = t + 1
Loop
End Sub
the same program how do we return not listing but connnected date with key
How do we remake the program to copy one value
I want to copy a table into a new Workbook while choosing which range I want to copy and knowing that the first Columns ("A") is automatically copied. (rows are not a problem, all of them have to be copied)
For example, i have a table composed of 28 rows and 10 columns. Added to A1:A28 (first columns, all rows),i want just to copy the column 5 and 8 with all its rows.
That's what i have until now but it doesn't work.
Sub CommandButton1_Click()
Dim newWB As Workbook, currentWB As Workbook
Dim newS As Worksheet, currentS As Worksheet
Dim CurrCols As Variant
Dim rng As rang
'Copy the data you need
Set currentWB = ThisWorkbook
Set currentS = currentWB.Sheets("Feuil1")
'select which columns you want to copy
CurrCols = InputBox("Select which column you want to copy from table (up to 10)")
If Not IsNumeric(CurrCols) Then
MsgBox "Please select a valid Numeric value !", vbCritical
End
Else
CurrCols = CLng(CurrCols)
End If
'Set rng = currentWB.currentS.Range(Cells(1, A), Cells(27, CurrCols)).Select
currentS.Range("A1:A27").Select
Selection.copy
Set rng = currentWB.currentS.Range(Cells(1, CurrCols), Cells(28, CurrCols)).Select
rng.copy
'Create a new file that will receive the data
Set newWB = Workbooks.Add
With newWB
Set newS = newWB.Sheets("Feuil1")
newS.Range("A1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
End With
End Sub
Can you help please solving it? Thanks in advance!
You can't copy a non-continuous range but you can load the data into an array and write it once to the new workbook.
Private Sub CommandButton1_Click()
Dim arData
Dim MyColumns As Range, Column As Range
Dim x As Long, y As Long
On Error Resume Next
Set MyColumns = Application.InputBox(Prompt:="Hold down [Ctrl] and click the columns to copy", Title:="Copy Columns to new Workbook", Type:=8)
On Error GoTo 0
If MyColumns Is Nothing Then Exit Sub
Set MyColumns = Union(Columns("A"), MyColumns.EntireColumn)
Set MyColumns = Intersect(MyColumns, ActiveSheet.UsedRange)
ReDim arData(1 To MyColumns.Rows.Count, 1 To 1)
For Each Column In MyColumns.Columns
y = y + 1
If y > 1 Then ReDim Preserve arData(1 To MyColumns.Rows.Count, 1 To y)
For x = 1 To Column.Rows.Count
arData(x, y) = Column.Rows(x)
Next
Next
With Workbooks.Add().Worksheets(1)
.Range("A1").Resize(UBound(arData, 1), UBound(arData, 2)) = arData
.Columns.AutoFit
End With
End Sub
try this (commented) code
Option Explicit
Sub CommandButton1_Click()
Dim newSht As Worksheet
Dim currCols As String
Dim area As Range
Dim iArea As Long
Set newSht = Workbooks.add.Worksheets("Feuil1") '<--| add a new workbook and set its "Feuil1" worksheet as 'newSht'
currCols = Replace(Application.InputBox("Select which column you want to copy from table (up to 10)", "Copy Columns", "A,B,F", , , , , 2), " ", "") '<--| get columns list
With ThisWorkbook.Worksheets("Feuil1") '<--| reference worksheet "Feuil1" in the workbook this macro resides in
For Each area In Intersect(.Range(ColumnsAddress(currCols)), .Range("A1:G28")).Areas ' loop through referenced worksheet areas of the range obtained by crossing its listed columns with its range "A1:G28"
With area '<--| reference current area
newSht.Range("A1").Offset(, iArea).Resize(.Rows.Count, .Columns.Count).value = .value '<--| copy its values in 'newSht' current column offset from "A1" cell
iArea = iArea + .Columns.Count '<--| update current column offset from 'newSht' worksheet "A1" cell
End With
Next area
End With
End Sub
Function ColumnsAddress(strng As String) As String
Dim elem As Variant
For Each elem In Split(strng, ",")
ColumnsAddress = ColumnsAddress & elem & ":" & elem & ","
Next
ColumnsAddress = Left(ColumnsAddress, Len(ColumnsAddress) - 1)
End Function
I think you can copy all column to a temp sheet and then write some code to delete the useless column. finally paste the table to your expected area.
Good morning,
I'm attempting to copy data from multiple worksheets (in cells M78:078) into one, where the name in the column (L) of the summary sheet matches to the worksheet name (pasting into columns Z:AA in the summary sheet.
At present the below code is erroring out:
Sub Output_data()
Application.ScreenUpdating = False
For Each ws In ActiveWorkbook.Worksheets
If ActiveSheet.Range("L:L").Value = wkSht.Name Then
ws.Range("M78:O78").Copy
ActiveSheet.Range("L").CurrentRegion.Copy Destination:=wkSht.Range("Z:AA").Paste
End If
Next ws
Application.ScreenUpdating = True
End Sub
Any help would be great.
DRod
Something like this should work for you. I commented the code in an attempt to explain what it does.
Sub Output_data()
Dim wb As Workbook
Dim ws As Worksheet
Dim wsGet As Worksheet
Dim LCell As Range
Dim sDataCol As String
Dim lHeaderRow As Long
sDataCol = "L" 'Change to be the column you want to match sheet names agains
lHeaderRow = 1 'Change to be what your actual header row is
Set wb = ActiveWorkbook
Set ws = wb.Sheets("Summary") 'Change this to be your Summary sheet
'Check for values in sDataCol
With ws.Range(sDataCol & lHeaderRow + 1, ws.Cells(ws.Rows.Count, sDataCol).End(xlUp))
If .Row <= lHeaderRow Then Exit Sub 'No data
'Loop through sDataCol values
For Each LCell In .Cells
'Check if sheet named that value exists
If Evaluate("ISREF('" & LCell.Text & "'!A1)") Then
'Found a matching sheet, copy M78:O78 to the corresponding row, column Z and on
Set wsGet = wb.Sheets(LCell.Text)
wsGet.Range("M78:O78").Copy ws.Cells(LCell.Row, "Z")
End If
Next LCell
End With
End Sub
I have a workbook that contains worksheets for each industry group in the S&P 500 and wrote the macro below to update all the stock information on them when I press a command button on the first worksheet. The macro works perfectly, but when I go to add additional sheets that I do not want to update with this macro it stops working. I tried using the "If Not" statements below, but it did not seem to work.
Sub Get_Stock_Quotes_from_Yahoo_Finance_API()
'Run the API for every sheet in the workbook
Dim Sht As Worksheet
For Each Sht In ThisWorkbook.Worksheets
'Look to see what the sheet is named and run the macro if it is not what is below
If Not Sht.Name = "Cover" _
And Not Sht.Name = "Select Industry" Then
Sht.Activate
' Dim varibales and set range
Dim head As Range
Set head = Worksheet.Range("A2")
'dim variables
Dim I As Integer
Dim Symbols As String: Symbols = ""
Dim SpecialTags As String: SpecialTags = ""
Dim Yahoo_Finance_URL As String: Yahoo_Finance_URL = "http://finance.yahoo.com/d/quotes.csv?s="
Dim rng As Range
Dim cell As Range
' Get the Stock Symbols
Set rng = Range(head.Offset(1, 0), head.Offset(1, 0).End(xlDown))
For Each cell In rng ' Starting from a cell below the head cell till the last filled cell
Symbols = Symbols & cell.Value & "+"
Next cell
Symbols = Left(Symbols, Len(Symbols) - 1) ' Remove the last '+'
' Get the Special Tags
Set rng = Range(head.Offset(0, 1), head.Offset(0, 1).End(xlToRight))
For Each cell In rng ' Starting from a cell to the right of the head cell till the last filled cell
SpecialTags = SpecialTags & cell.Value
Next
' Put the desciption/name of each tag in the cell above it
Dim SpecialTagsArr() As String: Dim TagNamesArr() As String
Call Get_Special_Tags(SpecialTagsArr, TagNamesArr)
For Each cell In rng
cell.Offset(-1, 0).Value = FindTagName(cell.Value, SpecialTagsArr, TagNamesArr)
Next
Yahoo_Finance_URL = Yahoo_Finance_URL & Symbols & "&f=" & SpecialTags
Call Print_CSV(Yahoo_Finance_URL, head)
Next Sht
'At the end of the program say it has all been updated
MsgBox ("All Data Updated")
End Sub
Change
If Not Sht.Name = "Cover" _
And Not Sht.Name = "Select Industry" Then
To
If Sht.Name <> "Cover" And Sht.Name <> "Select Industry" Then
Don't forget your End If before Next Sht
Refering to Kevin's second code - now the exclusion logic is flawed. I suggest the following:
Function IsIn(element, arr) As Boolean
IsIn = False
For Each x In arr
If element = x Then
IsIn = True
Exit Function
End If
Next x
End Function
Sub Get_Stock_Quotes_from_Yahoo_Finance_API()
Dim skippedSheets()
skippedSheets = Array("Cover,Select Industry,bla bla")
For Each Sh In ActiveWorkbook.Worksheets
If Not IsIn(Sh.Name, skippedSheets) Then
' ... process Sh
End If
Next Sh
End Sub
Now you have all sheet names which are to be excluded in one place (the array assignment) and the inner code block will only be executed if the current sheet name is not element of that array.
Second source of error: you already started qualifying the ranges (like in Set head = Sht.Range("A2")). Do the same in 2 other places, with
Set rng = Sht.Range(head.Offset(1, 0), head.Offset(1, 0).End(xlDown))
and
Set rng = Sht.Range(head.Offset(0, 1), head.Offset(0, 1).End(xlToRight))
Last, you don't have to activate a sheet. You work with the Sht object and qualified ranges.
Dim I as Integer is unused.