VBA - Copy Paste value base on the header - vba

Hello Friends & Community, I am trying to copy and paste value from one sheet to another base on the header.
For example I have Sheet1 with Table as below
20200101
20200102
20200103
123
234
234
333
233
232
And Sheet2 with Table as below
20200102
20200101
20200103
I would like my vba code to copy & paste the value from sheet1 to sheet 2 using header as reference.
Luckily I was able to find below code that execute exact operation as I wanted. But the only issue is that the header from original source(Sheet1)doesn't start at A1(row 1 column 1) as the syntax desired. Also the paste destination header doesnt start at A1 either. I tried to alter several parameter in below code but never able to get it work. If anyone can help me understand below syntax and instruct me on which parameter I need to change in order to paste correctly it will be greatly appreciated. Thank yoU!
Dim HeaderRow_A As Long
Dim HeaderLastColumn_A As Long
Dim TableColStart_A As Long
Dim NameList_A As Object
Dim SourceDataStart As Long
Dim SourceLastRow As Long
Dim Source As Variant
Dim i As Long
Dim ws_B_lastCol As Long
Dim NextEntryline As Long
Dim SourceCol_A As Long
Set wb = ActiveWorkbook
Set ws_A = wb.Worksheets("WIP-RSWW1")
Set ws_B = wb.Worksheets("Base Data_RS")
Set NameList_A = CreateObject("Scripting.Dictionary")
With ws_A
SourceDataStart = 2
HeaderRow_A = 2 'set the header row in sheet A
TableColStart_A = 2 'Set start col in sheet A
HeaderLastColumn_A = .Cells(HeaderRow_A, Columns.Count).End(xlToLeft).Column 'Get number of NAMEs you have
For i = TableColStart_A To HeaderLastColumn_A
If Not NameList_A.Exists(UCase(.Cells(HeaderRow_A, i).Value)) Then 'check if the name exists in the dictionary
NameList_A.Add UCase(.Cells(HeaderRow_A, i).Value), i 'if does not exist record name as KEY and Column number as value in dictionary
End If
Next i
End With
With ws_B 'worksheet you want to paste data into
ws_B_lastCol = .Cells(HeaderRow_A, Columns.Count).End(xlToLeft).Column ' Get number of DATA you have in sheet B
For i = 1 To ws_B_lastCol 'for each data
SourceCol_A = NameList_A(UCase(.Cells(1, i).Value)) 'get the column where the name is in Sheet A from the dictionaary
If SourceCol_A <> 0 Then 'if 0 means the name doesnt exists
SourceLastRow = ws_A.Cells(Rows.Count, SourceCol_A).End(xlUp).Row
Set Source = ws_A.Range(ws_A.Cells(SourceDataStart, SourceCol_A), ws_A.Cells(SourceLastRow, SourceCol_A))
NextEntryline = .Cells(Rows.Count, i).End(xlUp).Row + 1 'get the next entry line of the particular name in sheet A
.Range(.Cells(NextEntryline, i), _
.Cells(NextEntryline, i)) _
.Resize(Source.Rows.Count, Source.Columns.Count).Cells.Value = Source.Cells.Value
End If
Next i
End With
End Sub

Related

copy paste the matched columns from one worksheet to another

I have a question about copy paste specific columns from one worksheet(ws_Copy) to another(ws_Dest). I need to loop through each column header and match it with the headers in ws_Copy. If it matches, I need to copy the whole column into the ws_Dest with the matched header.
Not sure if my explain is clear or not, here is the sample code:
Sub Import_data()
Dim path As String
Dim file As String
Dim wsCopy As Worksheet
Dim wsDest As Worksheet
Dim lastcol As Integer
Dim lastrow_ir As Integer
Dim i As Integer
Dim m As Integer
path = ThisWorkbook.Sheets("MACROS").Range("import_path_IRHedge").Value
file = ThisWorkbook.Sheets("MACROS").Range("file_IRHedge").Value
'Set variables for copy and destination sheets
Set wsCopy = Workbooks(file).Sheets("data_ir_bpv")
Set wsDest = ThisWorkbook.Sheets("IR Hedge")
'Find last used column in the destination sheet
'Find last row in the copy sheet
lastcol = wsDest.Range("C:AD").Column
lastrow_ir = wsCopy_ir.Range("C" & Rows.Count).End(xlUp).Row
'Use the Match function to find the corresponding column to copy paste
For i = 3 To lastcol
Set Rng1 = wsCopy_ir.Range("C14:AC14")
m = Application.WorksheetFuntion.Match(wsDest.Cells(1, i).Value, Rng1, 0)
wsCopy_ir.Range("C14:C & lastrow_ir").Columns(m).Copy
wsDest.Range("C2").Columns(i).PasteSpecial xlPasteValues
Next i
Application.CutCopyMode = False
MsgBox "Data has been imported successfully"
End Sub
But the error message "Object doesn't support this property or method" kept showing up in the row:
m = Application.WorksheetFuntion.Match(wsDest.Cells(1, i).Value, Rng1, 0)
Any help would be appreciated!

Comparing two sheets and deleting the entire row

I have two sheets , Sheet1 and sheet2 .
Sheet 1 is my Source sheet and I am mentioning the item number in column A.
Sheet 2 is my destination sheet the contains the list of item number from the data base.
I am comparing the column A of source sheet with column E of my destination sheet, if they both have same item number then I am deleting the entire row.
I am using the below code for this. on 6 item number 4 are getting deleted and 2 are not getting deleted.
But, when I copy the same item number from the destination sheet to source sheet ,then it is getting deleted. I am not sure why this is happening. Could any one guide how I could figure this out.
below is the code
Sub spldel()
Dim srcLastRow As Long, destLastRow As Long
Dim srcWS As Worksheet, destWS As Worksheet
Dim i As Long, j As Long
Application.ScreenUpdating = False
Set srcWS = ThisWorkbook.Sheets("sheet1")
Set destWS = ThisWorkbook.Sheets("sheet2")
srcLastRow = srcWS.Cells(srcWS.Rows.count, "A").End(xlUp).Row
destLastRow = destWS.Cells(destWS.Rows.count, "E").End(xlUp).Row
For i = 5 To destLastRow - 1
For j = 1 To srcLastRow
' compare column E of both the sheets
If destWS.Cells(i, "E").Value = srcWS.Cells(j, "A").Value Then
destWS.Cells(i, "E").EntireRow.delete
End If
Next j
Next i
End Sub
Remember to loop in reverse order when you are trying to delete the rows otherwise rows may skipped from deletion even when they qualify the deletion criteria.
So the two For loops should be like this....
For i = destLastRow - 1 To 5 Step -1
For j = srcLastRow To 1 Step -1
Here is another approach:
Rather than looping through each item everytime in your source and destination sheets, just use MATCH function:
Function testThis()
Dim destWS As Worksheet: Set destWS = ThisWorkbook.Worksheets("Sheet8") ' Change to your source sheet
Dim srcWS As Worksheet: Set srcWS = ThisWorkbook.Worksheets("Sheet12") ' Change to your destination sheet
Dim iLR As Long: iLR = srcWS.Range("L" & srcWS.Rows.count).End(xlUp).Row ' Make sure you change the column to get the last row from
Dim iC As Long
Dim lRetVal As Long
On Error Resume Next
For iC = 1 To iLR
lRetVal = Application.WorksheetFunction.Match(srcWS.Range("L" & iC), destWS.Range("A:A"), 0)
If Err.Number = 0 Then
destWS.Range("A" & lRetVal).EntireRow.Delete
End If
Err.Clear
Next
On Error GoTo 0
End Function

Select cells that fit in the range of the counter and concatenate what is selected from the range

I've been working on a Macro that i need to copy, concatenate what has been selected through the counter. e.g. is below
excel snapshot example
so what i want to do is set a count in column c from 1 to "infinite" because each worksheet varies to go up to 10 or hundreds and when the counter hits a value of 1 again to stop concatenate column D what is in the range from 1 to "the last digit it stopped before hitting 1 again" and paste it on a different sheet. I know little to nothing on VBA but I understand the copy and paste to different sheet part. I'm just stuck on the counter and the concatenate part. Here is the code i have so far(i edited it to resemble the example for better reference)
'select counter/concatenate
Sheets(1).Select
Columns("C").EntireColumn
Do
Columns("C").Count
For i = 1 To 9999
Loop While (i <= 1)
If i = 1 Then
select.columns("D")
after the count is where i am stuck. this count is what I've come up with looking at different variations of counters.
I suggest you Forget about column and use just one cell for easier understanding. A cell is a reference that allows you to refer to any other cells on the sheet by using Offsets. You may use two Loops, the outer one crawling the columns, the inner one working downward until it finds 1
Dim i As Long ' note that in VBA integer Overflows at 65535 rows
Dim s As String
Set aCell = Worksheet("Sheet1").Range("D1")
While aCell.Column < 255
i = 0
s = ""
While Not aCell.Offset(i, 0).Value = 1
s = s & aCell.Offset(1, 0).Value
Wend
' paste s somewhere by using range.value = s
Set aCell = aCell.Offset(0, 1)
Wend
By specifying the workbook and worksheet before the range, you may refer to the proper cell without being dependent on the active worksheet or range.
Hope this works for you.
You can try this (not tested):
Dim s As String, firstAddr as String
Dim f as range, iniCell As Range
With Worksheet("MySheet") '<--| change "MySheet" to your actual sheet name
With .Range("C1", .Cells(.Rows.Count, 3).End(xlUp))
Set f = .Find(What:=1, LookAt:=xlWhole, LookIn:=xlValues, After:=.Cells(.Rows.Count, 1))
If Not f Is Nothing Then
firstAddr = f.Address
Set iniCell = f
Set f = FindNext(f)
Do While f.Address <> firstAddr
s = s & Join(Range(iniCell, f.Offset(-1)).Offset(, 1), "")
' here code to paste s somewhere
Set iniCell = f
Set f = FindNext(f)
Loop
End If
End With
End With
Here's one I actually tested, using some random data in columns C and D.
You'll have to modify a little to get exactly where you want the data to go, but should get you in the right direction.
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim i As Long
Dim s As String
Dim lastRow As Long
Dim c As Integer
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Set ws1 = ThisWorkbook.Sheets("Sheet1")
Set ws2 = ThisWorkbook.Sheets("Sheet2")
lastRow = ws1.Cells.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row
'This will get an accurate last row
c = 1
For i = 1 To lastRow
s = s & ws1.Cells(i, 4).Value 'Build the string
If ws1.Cells(i + 1, 3).Value = 1 Or ws1.Cells(i + 1, 3).Value = "" Then
ws2.Cells(c, 1).Value = s
s = ""
c = c + 1
'If the next cell to check is 1 or blank, then copy the values to the next cell in order on sheet2
End If
Next
End Sub
Walking through it, lastRow is set using the last row in the sheet with a value in it. Then, c is set to one, although you could set this to the last available row in ws2 using the same process. After that it just steps through the rows from 1 To LastRow building strings and transferring the value to ws2 when it's about to hit a 1.

If Cells in column A equal cells in column A on other workbook copy that row

I've been stuck on this for ages, it seems relatively simple in my head but I cant get it to work.. So what I need is say if I have a cell in workbook1 equals Bob, if that cell is in the same column in another workbook, copy that row..
So example.. if Bob in column A workbook1 is found in Column A workbook2 copy whatever is in the column b,c,d,e on bobs row into workbook2..
I could get it to work for singular ones easily but its for 500+ entries.
I've tried using arrays here is what I have got so far (the code is currently in a button on workbook1)
Dim owb As Workbook
Dim test1(500) As String, test2(500) As String, test3(500) As String, test4(500) As String
With Application
.DisplayAlerts = False
.ScreenUpdating = False
.EnableEvents = False
End With
fpath = "\Work\new location\test subject.xlsx" 'file location
Set owb = Application.Workbooks.Open(fpath) 'open file
For i = 1 To 500 'for each I
test1(i) = ThisWorkbook.Worksheets("Allsites").Cells(i, 1).Value
test2(i) = ThisWorkbook.Worksheets("Allsites").Cells(i, 8).Value
test3(i) = owb.Worksheets("Sheet2").Cells(i, 1).Value
test4(i) = owb.Worksheets("Sheet2").Cells(i, 2).Value 'declare locations
If test3(i) = test1(i) Then
test2(i) = test4(i)
End If
Next
In the example above, you're checking for a match in the exact cell (eg the value in A5 is the same as the one in A5), so I've assumed the same in the code below.
Dim sourceSheet As Worksheet
Dim destinationSheet As Worksheet
Dim columnNumber As Integer
Set sourceSheet = Worksheets("Sheet3")
Set destinationSheet = Worksheets("Sheet2")
Dim sourceArr() As Variant
Dim destArr() As Variant
sourceArr = sourceSheet.Range("A1:E500")
destArr = destinationSheet.Range("A1:E500")
For i = 1 To 500 'for each I
If destArr(i, 1) = sourceArr(i, 1) Then
For columnNumber = 2 To 5
destArr(i, columnNumber) = sourceArr(i, columnNumber)
Next
End If
Next
destinationSheet.Range("A1:A500").Value = destArr
There is a nice article about transferring data between arrays and worksheet ranges at http://www.cpearson.com/excel/ArraysAndRanges.aspx. Working with an array and writing the whole array in one go will be quicker than writing the value of each cell individually.
Update:
If the data can be in any row on the source spreadsheet, you can use Find to search for it. This may be quite a bit slower:
For i = 1 To 500 'for each I
Dim found As Range
Set found = searchRange.Find(destArr(i, 1), LookIn:=xlValues, lookat:=xlWhole)
If Not found Is Nothing Then
For columnNumber = 2 To 5
destArr(i, columnNumber) = found.Offset(0, columnNumber - 1)
Next
End If
Next
You may want to consider using a VLookup function in the worksheet rather than using VBA.

loop through columns on worksheet, copy data to new worksheet in new workbook - im stuck

I have a workbook that consists of several worksheets all with the same column headers. The rows in each worksheet identify an employee task and other task information. Columns starting at AB - BE containing an employee’s title as the column name along with email address in the row if they assisted in that task. Some of the rows are in a particular column if that employee roll has not touched that task.
I am looking to do the following.
Create a new workbook for new worksheets to be added
Loop through AB:BE and create a new worksheet in the new workbook with the column header name as the worksheet name
Filter this column (example: AB) to only include data that is in this list and not blanks
Copy this column data (AB as an example) into this new worksheet
Also copy Rows B, F, H from original worksheet to this new worksheet
Clear the filters on the main worksheet
Loop to next column (example AC) , repeat with creation of new worksheet in the workbook
I have done this in the past with rows just fine – I am having issues conceptually thinking about how this should work.
Does anyone have any examples? I have searched google for a few days and can get close in some areas however it does not scale well / loop on the data well.
Note: This could also be done with an Advanced Filter. That allows a filtered range to be copied to a new sheet.
I'm not sure I'm entirely understanding the sheet layout, but here's some basic code to create a new sheet for each column AB:BE, then for each row in column AB that is not empty, copy that cell value, along with the value in columns B, F, and H to a row in that new worksheet. Repeating then for columns AC:BE.
Sub CopyRoles()
Dim nSheet As Integer
Dim nTasks As Integer
Dim nSourceRow As Long
Dim nDestRow As Long
Dim wkb As Workbook
Dim wksSource As Worksheet
Dim wksDest As Worksheet
Set wksSource = ActiveSheet
Set wkb = Workbooks.Add
For nTasks = wksSource.Range("AB1").Column To wksSource.Range("BE1").Column
nSheet = nTasks - wksSource.Range("AB1").Column + 1
With wkb.Sheets
If .Count < nSheet Then ' Checks if sheet count on wkb exceeded
Set wksDest = .Add(after:=.Item(.Count), Type:=xlWorksheet)
Else
Set wksDest = .Item(nSheet) ' Keeps from having empty sheets
End If
wksDest.Name = wksSource.Cells(1, nTasks)
End With
With wksSource
wksDest.Cells(1, 1) = "E-mail address" ' Add header row to sheet
wksDest.Cells(1, 2) = .Cells(.UsedRange.Row, 2) ' Col B
wksDest.Cells(1, 3) = .Cells(.UsedRange.Row, 6) ' Col F
wksDest.Cells(1, 4) = .Cells(.UsedRange.Row, 8) ' Col H
nDestRow = 2
For nSourceRow = .UsedRange.Row + 1 To .UsedRange.Rows.Count
If .Cells(nSourceRow, nTasks).Value <> "" Then
wksDest.Cells(nDestRow, 1).FormulaR1C1 = _
.Cells(nSourceRow, nTasks).Value
wksDest.Cells(nDestRow, 2).FormulaR1C1 = _
.Range("B" & nSourceRow).Value
wksDest.Cells(nDestRow, 3).FormulaR1C1 = _
.Range("F" & nSourceRow).Value
wksDest.Cells(nDestRow, 4).FormulaR1C1 = _
.Range("H" & nSourceRow).Value
nDestRow = nDestRow + 1
End If
Next nSourceRow
End With
Next nTasks
wkb.SaveAs
End Sub