VBA - copy data from one worksheet t - vba

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

Related

Periodically Copying Concatenated Data in Excel To Second Sheet While Primary Sheet Remains Active for Data Entry

I am pulling data from various cells on Sheet1 in Excel and copying the values to specific cells on a row in Sheet2 every specified period of time. I almost have my project completed but am unable to copy concatenated data in the same manner. How would I incorporate the following excel statement into my code for the data to be copied on sheet2 from sheet1? The output should go into cell AB on Sheet2.
Not to confuse the issue but the reason the code is done in this manner is so that data can be entered on sheet 1 which will be the active sheet on the screen at all times but data will be periodically be saved to sheet2.
Excel Statement i need to incorporate and output to Cell "AB" on sheet2:
=CONCATENATE(Sheet1!I9,", ",Sheet1!I10,", ",Sheet1!I11,", ",Sheet1!I12)
Current Code:
Option Explicit
Public dTime As Date
Sub ValueStore()
Dim dTime As Date
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Set ws1 = ActiveWorkbook.Worksheets("Sheet1")
Set ws2 = ActiveWorkbook.Worksheets("Sheet2")
Dim lRow As Long
lRow = ws2.Range("A" & Rows.Count).End(xlUp).Row
With ws2
Range("X1:X" & lRow).Offset(1).Value = ws1.Range("F15").Value
Range("Y1:Y" & lRow).Offset(1).Value = ws1.Range("F14").Value
Range("Z1:Z" & lRow).Offset(1).Value = ws1.Range("F17").Value
Range("AA1:AA" & lRow).Offset(1).Value = ws1.Range("F16").Value
End With
StartTimer1
End Sub
Sub StartTimer1()
dTime = Now + TimeValue("00:00:05")
Application.OnTime dTime, "ValueStore", Schedule:=True
End Sub
Sub StopTimer1()
On Error Resume Next
Application.OnTime dTime, "ValueStore", Schedule:=False
End Sub
Try this:
Sub ValueStore()
Dim dTime As Date, rw As Range
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Set ws1 = ActiveWorkbook.Worksheets("Sheet1")
Set ws2 = ActiveWorkbook.Worksheets("Sheet2")
'find the next empty row on ws2
Set rw = ws2.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).EntireRow
With rw
' note the .Range() here is *relative* to rw
.Range("A1").Value = Now '<< ensure a value is placed in colA....
.Range("X1").Value = ws1.Range("F15").Value
.Range("Y1").Value = ws1.Range("F14").Value
.Range("Z1").Value = ws1.Range("F17").Value
.Range("AA1").Value = ws1.Range("F16").Value
'method1 (contiguous vertical range)
.Range("AB1").Value = Join(Application.Transpose(ws1.Range("I9:I12").Value), ", ")
'method2 (join individual cells)
.Range("AB1").Value = Join(Array(ws1.Range("I9"), ws1.Range("I10"), _
ws1.Range("I11"), ws1.Range("I12")), ", ")
End With
StartTimer1
End Sub

VBA check criteria in 1 workbook, input values in another workbook

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

VBA code only working correct in debug.mode

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.

(Excel) How Can I Add Worksheet Name as Prefix for Each Column Header?

I have a header that starts in Column E and might go on for 100+ columns.
I am trying to change each column header to add a prefix (the name of the "tab" aka. worksheet) (ie. if Worksheet is called 'Beverage', I'd like each column header to be prefixed with "Beverage -")
I will be running script across multiple sheets, so am trying to find a way to reference the current sheet name.
Before: (For Worksheet "Beverage")
After: (For Worksheet "Beverage". Note: Columns don't need to be resized, just did it to demonstrate)
I've tried adapting code from this thread, however I can't get it to work.
Here is the code I have so far (non-working):
Sub Worksheet_Name_Prefix()
Dim columnNumber As Long, x As Integer
Dim myTab As ListObject
Set myTab = ActiveSheet.ListObjects(rows.Count, 1)
For x = 5 To rows.Count ' For Columns E through last header cell with value
columnNumber = x
myTab.HeaderRowRange(1, columnNumber) = ActiveSheet.Name
Next x
End Sub
Any suggestions on what's wrong with my code? Any help would be greatly appreciated.
I hope this help you...
Sub Worksheet_Name_Prefix_v2()
Dim h 'to store the last columns/header
Dim rngHeaders As Range 'the whole range with the headers from E1 to x1
Dim i 'just and index
Dim sht As Worksheet 'the sheet where you want the job done
h = Range("E1").End(xlToRight).Column 'find the last column with the data/header
Set rngHeaders = Range(Cells(1, 5), Cells(1, h)) 'the range with the headers E = column 5
'Cells 1 5 = E1
'Cells 1 h = x1 where x is the last column with data
Set sht = ActiveSheet 'the sheet with the data, _
'and we take the name of that sheet to do the job
For Each i In rngHeaders 'for each cell in the headers (every cells in row 1)
i.Value = sht.Name & " - " & i.Value
'set the value "sheet_name - cell_value" in every cell
Next i
End Sub
If you need any emprovement please tell me... I'm not sure if I get the real idea of what you need.
Edit #1
Use this in a regular module:
Option Explicit
Sub goForEverySheet()
Dim noSht01 As Worksheet 'store the first sheet
Dim noSht02 As Worksheet 'store the second sheet
Dim sht 'just a tmp var
Set noSht01 = Sheets("AA") 'the first sheet
Set noSht02 = Sheets("Word Frequency") 'the second sheet
appTGGL bTGGL:=False
For Each sht In Worksheets ' for each sheet inside the worksheets of the workbook
If sht.Name <> noSht01.Name And sht.Name <> noSht02.Name Then
'IF sht.name is different to AA AND sht.name is diffent to WordFrecuency THEN
'TIP:
'If Not sht.Name = noSht01.Name And Not sht.Name = noSht02.name Then 'This equal
'IF (NOT => negate the sentence) sht.name is NOT equal to noSht01 AND
' sht.name is NOT equal to noSht02 THEN
sht.Activate 'go to that Sheet!
Worksheet_Name_Prefix_v3 'run the code
End If '
Next sht 'next one please!
appTGGL
End Sub
Sub Worksheet_Name_Prefix_v3()
Dim h 'to store the last columns/header
Dim rngHeaders As Range 'the whole range with the headers from E1 to x1
Dim i 'just and index
Dim sht As Worksheet 'the sheet where you want the job done
h = Range("E1").End(xlToRight).Column 'find the last column with the data/header
Set rngHeaders = Range(Cells(1, 5), Cells(1, h)) 'the range with the headers E = column 5
'Cells 1 5 = E1
'Cells 1 h = x1 where x is the last column with data
Set sht = ActiveSheet 'the sheet with the data, _
'and we take the name of that sheet to do the job
For Each i In rngHeaders 'for each cell in the headers (every cells in row 1)
i.Value = sht.Name & " - " & i.Value
'set the value "sheet_name - cell_value" in every cell
Next i
End Sub
Public Sub appTGGL(Optional bTGGL As Boolean = True)
Debug.Print Timer
Application.ScreenUpdating = bTGGL
Application.EnableEvents = bTGGL
Application.DisplayAlerts = bTGGL
Application.Calculation = IIf(bTGGL, xlCalculationAutomatic, xlCalculationManual)
End Sub
Your code was not running because, you do not use this line sht.Activate you say, for every sheet in the workbook do this, but you not say to go to every sheet, and the the code run n times in the same sheet (as many sheets there in the workbook less two). But if you say, for every sheet do this, AND got to each of one of that sheets and do this (less that two sheets) you will get whay you want

AdvancedFilter CopyToRange:= First empty row

I am trying to use AdvancedFilter in VBA, but instead of setting copy to range to a fixed value I want to copy it to the first empty row.
I am trying to append two tables from two separate AdvancedFilter steps, is there an easier way? E.g. first copy the two tables to separate location and then merge them? Both table have the same columns.
My code as of now is:
Set rngCriteria_v = Sheets("1").Range("filter")
Set rngExtract_v = Sheets("2").Range("**Here first empty row**")
Set rngData_v = Sheets("3").Range("Input")
rngData_v.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=rngCriteria_v, _
CopyToRange:=Sheets("Stocks_5_control").Columns("AG").Find(vbNullString, Cells(Rows.Count, "AG")), _
Unique:=False
Change your advanced filter line to this:
rngData_v.AdvancedFilter xlFilterCopy, rngCriteria_v, Sheets("Stocks_5_control").Cells(Sheets("Stocks_5_control").Rows.Count, "AG").End(xlUp)(2)
The following merges the all the worksheets in to a new sheet called Master. Hope that helps :)
Dim wrk As Workbook 'Workbook object - Always good to work with object variables
Dim sht As Worksheet 'Object for handling worksheets in loop
Dim trg As Worksheet 'Master Worksheet
Dim rng As Range 'Range object
Dim colCount As Integer 'Column count in tables in the worksheets
Dim wd As Object 'used for word document
Dim WDoc As Object
Dim strWorkbookName As String
Set wrk = ActiveWorkbook 'Working in active workbook
For Each sht In wrk.Worksheets
If sht.Name = "Master" Then
MsgBox "There is a worksheet called as 'Master'." & vbCrLf & _
"Please remove or rename this worksheet since 'Master' would be" & _
"the name of the result worksheet of this process.", vbOKOnly + vbExclamation, "Error"
Exit Sub
End If
Next sht
'Add new worksheet as the last worksheet
Set trg = wrk.Worksheets.Add(After:=wrk.Worksheets(wrk.Worksheets.Count))
'Rename the new worksheet
trg.Name = "Master"
'Get column headers from the first worksheet
'Column count first
Set sht = wrk.Worksheets(1)
colCount = sht.Cells(1, 255).End(xlToLeft).Column
'Now retrieve headers, no copy&paste needed
With trg.Cells(1, 1).Resize(1, colCount)
.Value = sht.Cells(1, 1).Resize(1, colCount).Value
'Set font as bold
.Font.Bold = True
End With
'We can start loop
For Each sht In wrk.Worksheets
'If worksheet in loop is the last one, stop execution (it is Master worksheet)
If sht.Index = wrk.Worksheets.Count Then
Exit For
End If
'Data range in worksheet - starts from second row as first rows are the header rows in all worksheets
Set rng = sht.Range(sht.Cells(2, 1), sht.Cells(65536, 1).End(xlUp).Resize(, colCount))
'Put data into the Master worksheet
trg.Cells(65536, 1).End(xlUp).Offset(1).Resize(rng.Rows.Count, rng.Columns.Count).Value = rng.Value
Next sht
'Fit the columns in Master worksheet
trg.Columns.AutoFit