Match Columns on two excel worksheets and copy data - vba

I have two data sheets within the same excel file:
Sheet1 as "Data" with 7 columns:
The second sheet is "Main" with 5 columns:
The same column to match the two files is "name". I want to have a VBA code that matches the name on both sheet and copy data from proc1 - Proc4 from sheet "Main" to sheet "data" by matching the column names on both sheets.
I searched stack overflow for similar question and here is the code that I found (modified it slightly):
Sub CopyData()
Dim shtImport As Worksheet
Dim shtMain As Worksheet
Set shtImport = ThisWorkbook.Sheets("Data")
Set shtMain = ThisWorkbook.Sheets("Main")
Dim CopyColumn As Long
Dim CopyRow As Long
Dim LastColumn As Long
'- for each column in row 1 of import sheet
For CopyColumn = 1 To shtImport.Cells(1, shtImport.Columns.Count).End(xlToRight).Column
'- check what the last column is with data in column
LastRowOfColumn = shtImport.Cells(shtImport.Columns.Count, CopyColumn).End(xlToRight).Column
'if last column was larger than one then we will loop through rows and copy
If LastColumn > 1 Then
For CopyRow = 1 To LastColumn
'- note we are copying to the corresponding cell address, this can be modified.
shtMain.Cells(CopyRow, CopyColumn).value = shtImport.Cells(CopyRow, CopyColumn).value
Next CopyRow
End If
Next CopyColumn
End Sub
This is not working the way I want it to work. Can somebody please help me with this problem. Thanks a lot!

Try this code:
Sub CopyData()
Dim shtImport As Worksheet
Dim shtMain As Worksheet
Set shtImport = ThisWorkbook.Sheets("Data")
Set shtMain = ThisWorkbook.Sheets("Main")
'From Main to Data
Dim rngImpTitles As Range
Set rngImpTitles = shtImport.Rows(1)
Dim rngImpNames As Range
Set rngImpNames = shtImport.Columns(1)
Dim CopyColumn As Long
Dim CopyRow As Long
Dim foundRow As Long
Dim foundCol As Long
On Error Resume Next
'for each column in row 1 of import sheet
For CopyColumn = 2 To shtMain.Cells(1, shtMain.Columns.Count).End(xlToLeft).Column
foundCol = rngImpTitles.Find(shtMain.Cells(1, CopyColumn).Value2).Column
If Err.Number <> 0 Then
MsgBox "Not such a col title in importsheet for " & vbNewLine & _
shtMain.Cells(1, CopyColumn)
Err.Clear
GoTo skip_title
End If
For CopyRow = 2 To shtMain.Cells(shtMain.Rows.Count, 1).End(xlUp).Row
foundRow = rngImpNames.Find(shtMain.Cells(CopyRow, 1)).Row
If Err.Number <> 0 Then
MsgBox "Not such a row name in importsheet for " & vbNewLine & _
shtMain.Cells(CopyRow, 1)
Err.Clear
GoTo skip_row
End If
If Len(shtMain.Cells(CopyRow, CopyColumn)) <> 0 Then
shtMain.Cells(CopyRow, CopyColumn).Copy shtImport.Cells(foundRow, foundCol)
End If
skip_row:
Next CopyRow
skip_title:
Next CopyColumn
End Sub

Related

VBA Cut entire row based on text in cell and paste to new sheet

I am attempting to have VBA scan cells in column DQ for a specific text value of "AcuteTransfer" and then to cut the row containing that cell and past into the first available row of a new sheet.
This value would be listed multiple times and each listing would need to be cut and pasted over
sheet containing the cell is "adds&reactivates" and sheet where row would be pasted to is "ChangeS".
Any recommendations would be amazing.
So far I have
Sub ohgodwhathaveIdone()
Dim endRow As Long
Dim Match1() As Variant
Dim ws As Worksheet
Set ws = Worksheets("adds&reactivates")
ICount = 0
endRow = Sheets("adds&reactivates").Range("DQ999999").End(xlUp).Row
Match1 = Sheet1.Range("DQ2:DQ" & endRow)
For I = LBound(Match1) To UBound(Match1)
If Match1(I, 1) = "AcuteTransfer" Then
Sheets("adds&reactivates").Cells(I, "A").EntireRow.Copy Destination:=Sheets("changes").Range("A" & Sheets("Changes").Rows.Count).End(xlUp).Offset(1)
Else
End If
Next I
End Sub
Try this out - this is assuming both pages have headers on row 1.
Option Explicit
Sub Test()
Dim sht1 As Worksheet, sht2 As Worksheet
Dim i As Long
Set sht1 = ThisWorkbook.Worksheets("adds&reactivates")
Set sht2 = ThisWorkbook.Worksheets("ChangeS")
For i = 2 To sht1.Cells(sht1.Rows.Count, "DQ").End(xlUp).Row
If sht1.Range("DQ" & i).Value = "AcuteTransfer" Then
sht1.Range("A" & i).EntireRow.Cut sht2.Range("A" & sht2.Cells(sht2.Rows.Count, "DQ").End(xlUp).Row + 1)
End If
Next i
End Sub

VBA: How can I limit a 'For Each' function

I am having a macro that checks the matching values from column A and row 2 in sheet2. Based on each value in the range B3 to C6 (dynamic field may get changed (there is maximum 7 location and below that 5 roles, may appears here ) in sheet1.
Problem with my code is that my loop "j" is not working as expected... It will result in executing the code 8 to 16 times in per below scenario (where I am expected it to run only 4 times)
Sub GetRowNum()
Dim rLoc
Dim rRol
Dim LocSrch1
Dim RolSrch1
Dim disRangeLoc As Range
Dim disRangeRol As Range
Dim i
Dim j
Dim shtA As Worksheet
Dim lRow As Long
Dim lCol As Long
Dim lInter As Variant
Dim Table As Range
Set shtA = Sheets ("Sheet1") 'storing the sheets...
Set shtB = Sheets ("Sheet2")
shtA.Activate
rLoc = shtA.Range("B2").End(xlDown).Row
rRol = shtA.Range("C2").End(xlDown).Row 'the last row of the list
LocSrch1 = 2 'column A... changed if you need
Set disRangeLoc = Range(Cells(3, LocSrch1), Cells(rLoc, LocSrch1)) 'here need to change the 2 for
'1 if you do not want headers
RolSrch1 = 3 'column A... changed if you need
Set disRangeRol = Range(Cells(3, RolSrch1), Cells(rRol, RolSrch1))
For Each i In disRangeLoc 'for each item inside the list of prod going to discount
For Each j In disRangeRol
MsgBox i
MsgBox j
shtB.Activate
Set Table = shtB.Range("A1:H7")
On Error Resume Next
lRow = shtB.Application.WorksheetFunction.Match(j, Range("A:A"), 0)
On Error GoTo 0
If lRow > 0 Then
End If
On Error Resume Next
lCol = shtB.Application.WorksheetFunction.Match(i, Range("2:2"), 0)
On Error GoTo 0
If lRow > 0 Then
End If
On Error Resume Next
lInter = Application.WorksheetFunction(lCol, lRow).Value
On Error GoTo 0
If lRow > 0 Then
MsgBox Table.Cells(lRow, lCol).Value
End If
On Error GoTo 0
Next j
Next i
End Sub
My final target is to find the revenue under D7 as shown in image1 (sheet1) and this code is 1st step towards it... If someone had a better suggestion to calculate in such a simple way, kindly guide me.
Someone, please help me to correct my code... And I hope u understand my requirement... Else please ask, I will try to explain better
Thanks in advance
If you set For Each j In disRangeRol then it will take each value in the range you already defined. if you keep Set J = I.Offset(0, 1) then it will consider and check the value in 'i' if true it will take the value just right to it and won't go for Each values in disRangeRol, Try below code
Sub GetRowNum() 'find the value from Sheet2 if Location and Role matches
Dim rLoc
Dim rRol
Dim LocSrch1
Dim RolSrch1
Dim disRangeLoc As Range
Dim disRangeRol As Range
Dim I
Dim J
Dim shtA As Worksheet
Dim shtB As Worksheet
Dim lRow As Long
Dim lCol As Long
Dim lInter As Variant
Dim Table As Range
Set shtA = Sheets("Sheet1")
Set shtB = Sheets("Sheet2")
shtA.Activate
rLoc = shtA.Range("B2").End(xlDown).row
rRol = shtA.Range("C2").End(xlDown).row 'the last row of the list
'with the discounted prods
'If you do not want headers,
'use A1 here
LocSrch1 = 2 'column B... changed if you need
Set disRangeLoc = Range(Cells(3, LocSrch1), Cells(rLoc, LocSrch1)) 'here need to change the 2 for
'1 if you do not want headers
RolSrch1 = 3 'column A... changed if you need
Set disRangeRol = Range(Cells(3, RolSrch1), Cells(rRol, RolSrch1))
For Each I In disRangeLoc 'for each item inside the list of prod going to discount
Set J = I.Offset(0, 1) 'it will check the value in i if yes it will take the value just right to it
shtB.Activate
Set Table = shtB.Range("A1:H7")
On Error Resume Next
lRow = shtB.Application.WorksheetFunction.Match(J, Range("A:A"), 0)
On Error GoTo 0
If lRow > 0 Then
End If
On Error Resume Next
lCol = shtB.Application.WorksheetFunction.Match(I, Range("2:2"), 0)
On Error GoTo 0
If lRow > 0 Then
End If
On Error Resume Next
lInter = Application.WorksheetFunction(lCol, lRow).Value
On Error GoTo 0
If lRow > 0 Then
'MsgBox I
'MsgBox J
MsgBox Table.Cells(lRow, lCol).Value
RevValue = Table.Cells(lRow, lCol).Value 'it will set the values each time the loop run
End If
On Error GoTo 0
shtA.Activate ' help to make sure you feed the date in right sheet, else data will get feed to Sheet2
ActiveCell.Value = RevValue & "," & ActiveCell.Value 'this will feed the date into the field using a comma separation
Next I
shtA.Activate
End Sub
Updated the code to feed the data into specific column as well

Create a summary sheet based on multiple worksheets

I have number of worksheets containing the same structure and same number of rows. Now I would like to create a master sheet to have an overview of all the worksheets using VBA.
It is like a balance sheet showing the performance over several years, which Years are on the headings and items are on rows.
Now the yearly data are put on multiple worksheets named "2012", "2013" and "2014".
Column B on sheet 1 ("2012") will be copied onto col B on "master" but for the following sheets ("2013", "2014"), data will be placed onto the next column on "master" (ie 2013 data on col C, 2014 data on col D).
I would like to have a workable macro which can count numbers of worksheets and copy paste specific data on a right column of master sheet.
1) create in a sheet a table like that: where the first column is where the destination cell in your Master report. And the 2nd column is where the data will be copied.
2) Put all your Worksheets in a folder
3) Run this macro, which need to be placed in Master module
Option Explicit
'assuming that:
'- "Excel Column Code" is in column A
'- "Form Cell Code" is in column B
'in zmaster.xlsm!Sheet2
Sub UpdateData()
Dim sFile As String, sPath As String
Dim srcWbk As Workbook, dstWbk As Workbook
Dim srcWsh As Worksheet, dstWsh As Worksheet, infoWsh As Worksheet
Dim i As Long, j As Long, k As Long
On Error GoTo Err_UpdateData
Set dstWbk = ThisWorkbook
Set dstWsh = dstWbk.Worksheets("Sheet1")
Set infoWsh = dstWbk.Worksheets("Sheet2")
sPath = "C:\Desktop\New folder\"
sFile = Dir(sPath)
Do While Len(sFile) > 0
If sFile = "zmaster.xlsm" Then
GoTo SkipNext
End If
Set srcWbk = Workbooks.Open(sPath & sFile)
Set srcWsh = srcWbk.Worksheets(1)
i = 2
'loop through the information about copy-paste method
Do While infoWsh.Range("A" & i) <> ""
'get first empty row, use "Excel Column Code" to get column name
j = GetFirstEmpty(dstWsh, infoWsh.Range("A" & i))
'copy data from source sheet to the destination sheet
'use "Form Cell Code" to define destination cell
srcWsh.Range(infoWsh.Range("B" & i)).Copy dstWsh.Range(infoWsh.Range("A" & i) & j)
i = i + 1
Loop
srcwbk.Close SaveChanges:=False
SkipNext:
sFile = Dir
Loop
Exit_UpdateData:
On Error Resume Next
Set srcWsh = Nothing
Set dstWsh = Nothing
Set srcWbk = Nothing
Set dstWbk = Nothing
Exit Sub
Err_UpdateData:
MsgBox Err.Description, vbExclamation, Err.Number
Resume Exit_UpdateData
End Sub
'returns first empty row in a destination sheet based on column name
Function GetFirstEmpty(ByVal wsh As Worksheet, Optional ByVal sCol As String = "A") As Long
GetFirstEmpty = wsh.Range(sCol & wsh.Rows.Count).End(xlUp).Row + 1
End Function

Dynamically set Ranges to the columns in VBA

I am importing some date to worksheet which needs to be ranged for validation and reference in other worksheets.
Say I have 4 columns in worksheet(WS1) but the row count is dynamic on every import. How can i range the columns(A:D)?
Please help.
Regards,
Mani
Use a lastRow variable to determine the last row. I included a few examples of this. Also on this example is a lastCol variable.. You can use this if the number of Columns is dynamic as well.
Private Sub lastRow()
Dim lastRow As Long
Dim lastCol As Long
Dim sheet As String
sheet = "WS1"
lastRow = Sheets(sheet).Range("A" & Rows.Count).End(xlUp).row 'Using Range()
lastRow = Sheets(sheet).Cells(Rows.Count, "A").End(xlUp).row 'Using Cells()
lastCol = Sheets(sheet).Cells(2, Columns.Count).End(xlToLeft).Column
End Sub
You can loop through your sheet easily enough using variables also. Using Cells(row,col) instead of Range(A1). you can use numbers or a letter in quotes for the column as shown in the example.
This example looks at WS1 and matches someValue. If the value in Column A of WS1 = somevalue, the record is copied to a "Master" Sheet.
Sub LoopExample()
Dim mRow As Long 'used for a master row
For lRow = 2 To lastRow
If Sheets(sheet).Cells(lRow, 1) = someValue Then
'perform something here like this. Copy columns A:D to the Master Sheet if match
For lCol = 1 To 4 'or you could go 1 to lastCol if you needed it dynamic
Sheets("MASTER").Cells(mRow, lCol) = Sheets(sheet).Cells(lRow, lCol) 'mRow as Row on Master
Next lCol
mRow = mRow + 1 'Increment the Master Row
End If
Next lRow
End Sub
Thanks anyways. But what i wanted was just to Name ranges the columns in worksheet.
I have already accomplished the copy and paste (Loading data b/w worksheets).
This is what i wanted.
vRowCount = DestWorkSheet.Cells(1, 1).SpecialCells(xlCellTypeLastCell).Row
vColCount = DestWorkSheet.Cells(1, 1).SpecialCells(xlCellTypeLastCell).Column
DestWorkSheet.usedRange.Columns.AutoFit
AddNamedRange Dest_RATES, DATA_Dest_RATES
Where AddNamedRange is a function,
Public Sub AddNamedRange(ByVal sheetCodeName As String, ByVal namedRange As String)
Dim rngToBeNamed As Range
Dim ws As Worksheet
On Error GoTo AddNamedRange_Error
Set rngToBeNamed = GetUsedRange(sheetCodeName)
Set ws = rngToBeNamed.Worksheet
ws.Names.Add name:=namedRange, RefersTo:=ws.Range(rngToBeNamed.Address)
On Error GoTo 0
Exit Sub
AddNamedRange_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure AddNamedRange of Module UtilitiesRange"
End Sub
Regards,
Mani
Seems like you could just use something like this in the sheet module:
Private Sub Worksheet_Change(ByVal target As Range)
Dim i As Long
Dim NamesOfNames(1 To 4) As String
NamesOfNames(1) = "NameOfColumn1"
NamesOfNames(2) = "NameOfColumn2"
NamesOfNames(3) = "NameOfColumn3"
NamesOfNames(4) = "NameOfColumn4"
For i = 1 To 4
ThisWorkbook.Names.Add Name:=NamesOfNames(i), _
RefersTo:=Range(Cells(1, i), Cells(Cells(Rows.Count, i).End(xlUp).Row, i))
Next i
End Sub

Excel VBA Macro--Search For Column names and then copy into defined columns on another template worksheet in same workbook Excel 2010

I can't seem to get this to work, I don't see where there is an issue.
It compiles fine, but it does nothing on my sheets. I am trying to write a macro that will Copy data by column header and paste into another template sheet within the same workbook with the same header.
For example, copy data under column "Time Started" on the import sheet, copy the new data, and paste into "Time Started" column on the Main sheet.
Sub CopyByHeader()
Dim shtImport As Worksheet, shtMain As Worksheet
Dim c As Range, f As Range
Dim rngCopy As Range, rngCopyTo
Set shtImport = ActiveSheet ' "import" - could be different workbook
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
I changed to this, which is super slow...any thoughts??:
Sub ImportTimeStudy()
Dim myHeaders, e, x, wsImport As Worksheet, wsMain As Worksheet
Dim r As Range, c As Range
myHeaders = Array(Array("Time Started", "Time Started"), Array("Description of the task", "Description of the task"), Array("Level", "Level"), Array("Location", "Location"), Array("Targeted", "Targeted"), Array("System", "System"), Array("Process Code", "Process Code"), _
Array("Value Stream", "Value Stream"), Array("Subject", "Subject"), Array("BU", "BU"), Array("Task Duration", "Task Duration"), Array("Activity Code", "Activity Code"))
Set wsImport = Sheets("Import")
Set wsMain = Sheets("Main")
For Each e In myHeaders
Set r = wsImport.Cells.Find(e(0), , , xlWhole)
If Not r Is Nothing Then
Set c = wsMain.Cells.Find(e(1), , , xlWhole)
If Not c Is Nothing Then
wsImport.Range(r.Offset(1), wsImport.Cells(Rows.Count, r.Column).End(xlUp)).Copy _
wsMain.Cells(Rows.Count, c.Column).End(xlUp)(2)
Else
msg = msg & vbLf & e(1) & " " & wsMain.Name
End If
Else
msg = msg & vbLf & e(0) & " " & wsImport.Name
End If
Next
If Len(msg) Then
MsgBox "Header not found" & msg
End If
Application.ScreenUpdating = False
End Sub
I rewrote your loops to be 2 for loops, give this a try:
(comments in-line)
Sub CopyByHeader()
Dim shtImport As Worksheet
Dim shtMain As Worksheet
Set shtImport = ActiveSheet ' "import" - could be different workbook
Set shtMain = ThisWorkbook.Sheets("Main")
Dim lCopyColumn As Long
Dim lCopyRow As Long
Dim lLastRowOfColumn As Long
'- for each column in row 1 of import sheet
For lCopyColumn = 1 To shtImport.Cells(1, shtImport.Columns.Count).End(xlToLeft).Column
'- check what the last row is with data in column
lLastRowOfColumn = shtImport.Cells(shtImport.Rows.Count, lCopyColumn).End(xlUp).Row
'if last row was larger than one then we will loop through rows and copy
If lLastRowOfColumn > 1 Then
For lCopyRow = 1 To lLastRowOfColumn
'- note we are copying to the corresponding cell address, this can be modified.
shtMain.Cells(lCopyRow, lCopyColumn).Value = shtImport.Cells(lCopyRow, lCopyColumn).Value
Next lCopyRow
End If
Next lCopyColumn
End Sub