I have a spreadsheet with existing workers' names, IDs, and addresses.
These workers are hired and fired many times.
I pull a report (external data from a website) that lists these workers' names, IDs, and addresses that are currently employed.
Instead of adding and deleting the rows of these workers on my table(the table on the MASTER sheet) to match the report(the data on the EXTERNAL DATA sheet), I would like to add the rows of workers from the report(EXTERNAL DATA sheet) to my table(MASTER sheet) automatically without duplicates.
The reason I need to add the whole row is because I have more columns in the table(on the MASTER sheet) so I can add their job title, shift, and incentive pay. So I need to delete the whole row when I delete the worker...
I need some code to add rows from the external data table(EXTERNAL DATA sheet) on one sheet to my MASTER table on another sheet without duplicate workers.
This code works great on my sheet now. I might be able to adapt this code with some help...
`Private Sub Worksheet_Change(ByVal Target As Range)
' Code to move row from FIRED sheet to MASTER sheet when “REHIRED” is
'selected in column J
If Target.Column = 2 Then
' The line below is where I should change to something to compare if there
'is a new number
'in the "NUMBER" column of the "EXTERNAL DATA" sheet then move the row to
'the "MASTER" table.
If Target = "REHIRED" Then
Application.EnableEvents = False
nxtRow = Sheets("MASTER").Range("H" & Rows.Count).End(xlUp).Row + 1
Target.EntireRow.Copy _
Destination:=Sheets("MASTER").Range("A" & nxtRow)
Target.EntireRow.Delete
End If
End If
Application.EnableEvents = True
End If
End Sub`
I hope this makes sense.
Edit: updated/tested. Assumes both sets of data are formatted as Tables/ListObjects:
Sub Tester()
Dim lo As ListObject, loExt As ListObject, lr As ListRow
Dim rw As Range, shtExt As Worksheet, f As Range, shtMaster As Worksheet
Dim rwNew As Range
Set shtExt = Sheets("external data")
Set shtMaster = Sheets("master")
Set lo = shtMaster.ListObjects(1) 'or use the table name
Set loExt = shtExt.ListObjects(1) 'assumes the external data is a listobject
For Each lr In loExt.ListRows
'try to find the Id on the master sheet
Set f = lo.ListColumns(1).Range.Find(lr.Range(1).Value, lookat:=xlWhole)
If f Is Nothing Then
'no match: add a new row to the table
Set rwNew = shtMaster.ListObjects(1).ListRows.Add().Range
'populate the new row
rwNew.Cells(1).Value = lr.Range(1).Value
rwNew.Cells(2).Value = lr.Range(2).Value
rwNew.Cells(3).Value = lr.Range(3).Value
'etc transfer any other required values...
End If
Next lr
End Sub
Related
I'm trying to create a VBA script that goes into file1 and copies the data into file2. File 1 contains the data.
The issue I'm having is file2 has more columns and not necessarily in the same order as the ones in file1. As well, the Range is wrong, I'm not sure how to select all relevant data. How do i make sure it gets all the relevant rows per column in file1?
Sub GetDatacClosedBook()
Dim src As Workbook
Set src = Workbooks.Open("C:\Users\Data\Documents\File1", True, True)
Set wbOpen = ActiveWorkbook
'this is the workbook in which the data will be transferred to
Workbooks.Open "C:\Users\Data\Documents\file2.xlsx"
Worksheets("Sheet1").Range("A1:D3").Formula = src.Worksheets("Sheet1").Range("A1:D3").Formula
wbOpen.Close
End Sub
You should first figure out the columns in your data sheet match which columns in your destination sheet. And then everything should be easy. This can be done in multiple way. I assume your A row has the headers, then you can match the column by match the headers
Sub Macro()
Dim destSht As Worksheet, srcSht As Worksheet
Dim src_ColCnt As Integer, dest_ColCnt As Integer
'Open the workbooks and grab the sheet reference, assign it to a worksheet variables
Set srcSht = Workbooks.Open("D:\data.xlsx").Sheets("Sheet1")
Set destSht = Workbooks.Open("D:\report.xlsx").Sheets("Sheet1")
'Find how many columns in your destination sheet, how many columns in your source sheet and how many rows the source sheet data has.
dest_ColCnt = destSht.Range("A1").End(xlToRight).Column
src_ColCnt = srcSht.Range("A1").End(xlToRight).Column
src_RCnt = srcSht.Range("A1").End(xlDown).Row - 1
'The code below is basically loop over the source sheet headers, and for each header
'find the column in your destination that has the same header
'And then assign the data row by row once it knows which column in the data sheet go to which column in the destination sheet
For i = 1 To src_ColCnt
Header = srcSht.Cells(1, i)
For j = 1 To dest_ColCnt
If destSht.Cells(1, j).Value = Header Then
For r = 1 To src_RCnt
'Do your assignment here row by row
'You can assign formula, value or different thing based on your requirement
'I assume your data start from the second row here
destSht.Cells(r + 1, j).Value = srcSht.Cells(r + 1, i).Value
Next r
End If
Next j
Next i
End Sub
This is not elegant but should give you the idea. To make the above more elegant, There are a couple of things you can use. One, using Scripting.Dictionary data structure to hold the headers in the dictionary as key, the column ordinal as the value. And then you loop your destination sheet column by column. Retrieve the right column ordinal from the dictionary. Two, you can use WorksheetFunctions.Match() to find the ordinal. Or even better if you know the order by yourself. You can just hard coding an order Array, like mapOrder = Array(3,1,5,6) and just use this array to match the column.
You could write a function that points to a specific workbook, locates a column -perhaps by heading- and captures that columns data into an Array which is returned by the function.
Then write the arrays in the desired order to the other sheet.
Example for the Subroutine and the function:
Private Sub GetDatacClosedBook()
Dim ExampleArray As Variant
Dim Destination As Range
ExampleArray = LocateColumnReturnArray(ThisWorkbook.Sheets("Sheet1"), "Value to find in row1 of the desired column")
Set Destination = ThisWorkbook.Sheets("Sheet2").Range("A1")
Destination.Resize(UBound(ExampleArray), 1) = ExampleArray
End Sub
Public Function LocateColumnReturnArray(ByRef TargetWorksheet As Worksheet, ByVal TargetColumnHeader As String) As Variant
Dim LastUsedColumn As Long
Dim TargetCell As Range
With TargetWorksheet
LastUsedColumn = .Cells(1, .Columns.Count).End(xlToLeft).Column
For Each TargetCell In .Range(.Cells(1, 1), .Cells(1, LastUsedColumn))
If TargetCell.Value = TargetColumnHeader Then
LastUsedRow = .Cells(.Rows.Count, LastUsedColumn).End(xlUp).Row
LocateColumnReturnArray = .Range(.Cells(2, TargetCell.Column), .Cells(LastUsedRow, TargetCell.Column))
Exit Function
End If
Next TargetCell
End With
End Function
You can take this concept and apply it to your requirements.
This function could be run as many times as required for each column you want the data for.
You would need to also specify the target for each column of data but you could modify the above to use a loop based on the columns your data is being written to.
I have a sheet that starts with two data validation drop down lists, one for day and one for time. I want to create a macro that shows the corresponding data for the selected day/ time combo. Right now, on another sheet is a table for each day, with that day's hourly data in the columns of the table. Ideally, once both DV list cells are changed, the macro would find the correct day's table, find the right hour column, then select the data and paste it into a range on the sheet. What I have so far runs but doesn't actually do anything.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim tbl As ListObject, sht As Worksheet, clm As Range
Set sht = Worksheets("Data")
If Not Intersect(Target, Target.Worksheet.Range("B2")) Is Nothing Then
For Each tbl In sht.ListObjects
If tbl.Name = Sheets("Heat Map").Range("B1").Value Then
For i = 1 To NumCols
If Cells(2, i).Value = Sheets("Heat Map").Range("B2").Value Then
Sheets("Heat Map").Range("B4:B21").Value = tbl.Range(Cells(3, i), Cells(20, i)).Value
End If
Next i
End If
Next tbl
End If
End Sub
I have a table, with a lot of columns. I'd like to filter the table one after the other by a few values appearing in one specific column. Once the table is filtered (for one value), I'd like to copy the result to a new sheet and go on with the second value. (Actually I'd like to copy it to a new workbook and save it, but that's the next step.)
Here's my code:
'Start Loop
Public Sub LP()
Dim years As Variant
Dim number As Variant
'Array for loop
years = Array("2013", "20131", "20132")
For Each number In years
' filter definition (filter by number)
Dim i As Integer, rngData As Range
Set rngData = Range("A1").CurrentRegion
i = Application.WorksheetFunction.Match("ColumnXY", Range("A1:BM1"), 0)
rngData.AutoFilter field:=i, Criteria1:=number
'Copy filtered data to new sheet
Dim rng As Range
Dim WS As Worksheet
For Each row In Range("Tabelle1[#All]").Rows
If row.EntireRow.Hidden = False Then
If rng Is Nothing Then Set rng = row
Set rng = Union(row, rng)
End If
Next row
Set WS = Sheets.Add
rng.copy Destination:=WS.Range("A1")
'Delete specific columns in the new sheet
WS.Range("A:AD,AP:AQ,AS:BE,BG:BH,BJ:BK").EntireColumn.Delete
'Autofit Column
Columns("A:N").Select
Range(Selection, Selection.End(xlToRight)).Select
Cells.EntireColumn.AutoFit
'Tabelle1=1 active table
Sheets("Tabelle1").Select
'Remove filter and show all data
If ActiveSheet.FilterMode Then
ActiveSheet.ShowAllData
End If
'go on with next number
Next number
End Sub
3 Sheets will be generated after running the script and the first sheet is fine (all datas of 2013). The second sheet contains unfortunally all rows from the frist two numbers (2013 and 20131) and the third sheet contains the data from all numbers. I aim to get a sheet for the data for one number indivudally and I can't see, what's wrong ...
Thanks for your help!
I have a workbook filled with text-based data on several different sheets. All the sheets use the same headings, but have different text in the columns. I would like to be able to list the information contained in the column C from all of the sheets in a single column in a new sheet.
Is there a way to get all of that data into a single column without having to copy and past from nearly 100 different sheets?
Using VBA, here is a solution that works. You just need to insert a module into your workbook and run this. F11 > Insert > Module. Copy and paste this code, and hit play.
This will create a new worksheet with whatever name you define under newSheet. Then take the contents of EVERY worksheet Row C (after header), no matter how many you have or what their name is, and add them to the new one. I could see a problem if you exceed 1,000,000 rows.. Other than that, if there are any sheets you DON'T want to perform this on, we would add them as exceptions specifically by name in the If statement.
TESTED:
Private Sub CopyAllSheetsCol()
Dim WS As Worksheet
Dim newSheet As String
Dim lastRow As Long 'Last Row on source Sheet
Dim tRow As Long 'target row
newSheet = "Compiled" 'name can be changed here
Sheets.Add.Name = newSheet
tRow = 2 'Set the target Row to 2, Set the Header Row manually
For Each WS In ActiveWorkbook.Worksheets
If WS.Name <> newSheet Then 'Making sure we are only working with pre-existing sheets
lastRow = Sheets(WS.Name).Range("C2").End(xlDown).Row 'get last row of Column C on each Worksheet
For r = 2 To lastRow 'Loop through all rows skipping header
Sheets(newSheet).Cells(tRow, "C") = Sheets(WS.Name).Cells(r, "C") 'Copy to newSheet
tRow = tRow + 1 'Increment target row by 1
Next r
End If
Next
End Sub
edit: touched up explanation
I am fairly new to Excel VBA and have been trying to look for (as well as come up with my own) solutions to a dilemma I am facing. Routinely, I receive raw data files from a colleague and these raw data files may have varying number of columns but consistent header names. I have in my workbook, a master spreadsheet that I want to keep up to date by appending the new data (so keep appending data of new spreadsheet to next empty row). I would like to create a macro that can take the imported spreadsheet (say, spreadsheet A) and look at the header value of a column, copy the column range (starting from row 2 to end of populated within column), go to spreadsheet Master, look for header value, and paste the column range in the next empty cell down in the column. And this procedure would be for all columns present in spreadsheet A.
Any help/guidance/advice would be very much appreciated.
Ex) I have "master" sheet and "imported" sheet. I want to take the "imported" sheet, look at headers in row 1, starting from column 1. If that header is present in "master" sheet, copy the column (minus the header) from "imported sheet" and paste into "master" under the appropriate column header starting from the next empty cell in that column. What I ultimately want to do is keep the "master" sheet with historical data but the "imported" sheet contains columns which moves around so I just couldn't copy and paste the range starting from next empty cell in master.
Untested but compiles OK:
Sub CopyByHeader()
Dim shtA As Worksheet, shtB As Worksheet
Dim c As Range, f As Range
Dim rngCopy As Range, rngCopyTo
Set shtA = ActiveSheet ' "incoming data" - could be different workbook
Set shtB = ThisWorkbook.Sheets("Master")
For Each c In Application.Intersect(shtA.UsedRange, shtA.Rows(1))
'only copy if >1 value in this column (ie. not just the header)
If Len(c.Value) > 0 And Application.CountA(c.EntireColumn) > 1 Then
Set f = shtB.Rows(1).Find(what:=c.Value, LookIn:=xlValues, _
LookAt:=xlWhole)
If Not f Is Nothing Then
Set rngCopy = shtA.Range(c.Offset(1, 0), _
shtA.Cells(Rows.Count, c.Column).End(xlUp))
Set rngCopyTo = shtB.Cells(Rows.Count, _
f.Column).End(xlUp).Offset(1, 0)
'copy values
rngCopyTo.Resize(rngCopy.Rows.Count, 1).Value = rngCopy.Value
End If
End If
Next c
End Sub
EDIT: updated to only copy columns which have any content, and to only copy values
I cannot get the above to work, and need the same result as the original question. Any thoughts on what is missing? I thought I changed everything that needed to be changed to fit my sheets:
Sub CopyByHeader()
Dim shtMain As Worksheet, shtImport As Worksheet
Dim c As Range, f As Range
Dim rngCopy As Range, rngCopyTo
Set shtImport = ActiveSheet
' "Import"
Set shtMain = ThisWorkbook.Sheets("Main")
For Each c In Application.Intersect(shtImport.UsedRange, shtImport.Rows(1))
'only copy if >1 value in this column (ie. not just the header)
If Len(c.Value) > 0 And Application.CountA(c.EntireColumn) > 1 Then
Set f = shtMain.Rows(1).Find(what:=c.Value, LookIn:=xlValues, _
LookAt:=xlWhole)
If Not f Is Nothing Then
Set rngCopy = shtImport.Range(c.Offset(1, 0), _
shtImport.Cells(Rows.Count, c.Column).End(xlUp))
Set rngCopyTo = shtMain.Cells(Rows.Count, _
f.Column).End(xlUp).Offset(1, 0)
'copy values
rngCopyTo.Resize(rngCopy.Rows.Count, 1).Value = rngCopy.Value
End If
End If
Next c
End Sub
Thanks,
Ryan