Sheet 1
E-Code E-Name
11621 Hari
12205 Dass
11709 Boss
11913 Pass
11755 Test
Sheet 2
E-Code
11621
11709
11913
11755
12205
I want to run a macro which automatically do the vlookup function in sheet 2 against the E-Code which are unique fields.
The macro which i have created is as below. However when i change the data it is not working.
Sub Macro()
Sheets("Sheet2").Select
Range("B2").Select
ActiveCell.FormulaR1C1 = "=VLOOKUP(RC[-1],Sheet1!C[-1]:C,2,0)"
Range("B2").Select
ActiveCell.FormulaR1C1 = "=VLOOKUP(RC[-1],Sheet1!C1:C2,2,0)"
Range("B2").Select
Selection.Copy
Range("B3:B6").Select
ActiveSheet.Paste
Range("A1").Select
End Sub
I have checked your code. It is working fine. However, if you increase the no of rows it will not take into account. Please find the below code which will find the no of rows in Sheet1 and Sheet2.
Sub Macro1()
Dim sht1 As Worksheet
Dim sht2 As Worksheet
Set sht1 = ThisWorkbook.Sheets("Sheet1")
Set sht2 = ThisWorkbook.Sheets("sheet2")
Sh1Rows = sht1.Range("A" & Rows.Count).End(xlUp).Row
sh2rows = sht2.Range("A" & Rows.Count).End(xlUp).Row
sht2.Range("B2") = "=Vlookup(A2," & sht1.Name & "!" & sht1.Range("A2:B" & sh2rows).Address & ",2,false)"
sht2.Range("B2").Copy sht2.Range("B2:B" & sh2rows)
End Sub
Related
New VBA user here, the below code matches the 1st column in a worksheet with the 1st column in another worksheet using vlookup then copies the first cell from 1st to 2nd as the screenshots.
Code
Sub solution()
Dim oldRow As Integer
Dim newRow As Integer
Dim lrow_output As Integer 'variable indicating last fulfilled row
Dim WB_Input As Workbook
Dim WB_Output As Workbook
Dim WS_Input As Worksheet
Dim WS_Output As Worksheet
Dim funcStr As String
Set WB_Input = Workbooks("input")
Set WB_Output = Workbooks("output1")
Set WS_Input = WB_Input.Worksheets("input")
Set WS_Output = WB_Output.Worksheets("Sheet1")
With WS_Output
lrow_output = .Cells(.Rows.Count, 1).End(xlUp).Row
End With
With WS_Input
funcStr = "=IFERROR(VLOOKUP(" & Cells(1, 1).Address(False, False) & "," & "'[" & WB_Input.Name & "]" & .Name & "'!" & Range(.Columns(1), .Columns(2)).Address & ",2,0),"""")"
End With
With WS_Output
.Cells(1, 2).Formula = funcStr
.Cells(1, 2).Copy
Range(.Cells(1, 2), .Cells(lrow_output, 2)).PasteSpecial xlPasteFormulas
WS_Output.Calculate
Range(.Cells(1, 2), .Cells(lrow_output, 2)).Copy
Range(.Cells(1, 2), .Cells(lrow_output, 2)).PasteSpecial xlPasteValues
Application.CutCopyMode = False
End With
End Sub
Problem: I need the code to copy and paste the all data in the row, not just the first cell.
Problem2:If possible I need the code to scan multiple sheets, not just one so it would be 1 input main workbook sheet and 4 output sheets in the output workbook.
Problem3(Optional): if possible I need the successfully matched and copied rows in the input workbook to be colored to tell them from the unsuccessful matches.
Thank you in advance, I really appreciate all the possible aid.
Here is a quick macro that will take the active cell row copy it and then select specified sheet and paste it in active cell row:
Sub CopyPaste()
'
' CopyPaste Macro
'
'
ActiveCell.Rows("1:1").EntireRow.Select
Selection.Copy
Sheets("Sheet#").Select
ActiveCell.Rows("1:1").EntireRow.Select
ActiveSheet.Paste
End Sub
I am trying to copy a sheet and then in a separate summary sheet create formula’s that link to cells in this newly created copy.
I am not having much success which may be an issue with how I’ve identified and named the new sheet or with how I’ve constructed the formulas (or both).
Sub CopyCosting()
'
Dim currentNPD As String
Dim currentCOST As String
Dim currentCALC As String
Dim NewNPD As String
Dim NewCOST As String
Dim NewCALC As String
ActiveSheet.Select
currentNPD = ActiveSheet.Name
ActiveSheet.Next.Select
currentCOST = ActiveSheet.Name
ActiveSheet.Next.Select
currentCALC = ActiveSheet.Name
Sheets(Array(currentNPD, currentCOST, currentCALC)).Copy After:= _
Sheets("SUMMARY")
Worksheets("SUMMARY").Select
ActiveSheet.Next.Select
NewNPD = ActiveSheet.Name
ActiveSheet.Next.Select
NewCOST = ActiveSheet.Name
ActiveSheet.Next.Select
NewCALC = ActiveSheet.Name
Worksheets("SUMMARY").Select
NextFree = Range("B9:B" & Rows.Count).Cells.SpecialCells(xlCellTypeBlanks).Row
Range("A" & NextFree).EntireRow.Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Range("B" & NextFree).Select
ActiveCell.FormulaR1C1 = _
"=NewCOST!R[-39]C[-1]&"" (""&NewCOST!R[-35]C[3]&""x""&NewCOST!R[-37]C[3]&""g)"""
ActiveCell.Offset(0, 1).Activate
ActiveCell.FormulaR1C1 = "=IF(NewCOST!R[-40]C[5]>49,""AYR"",""Seasonal"")"
End Sub
The excel formula #REFS and in relation to the first concatenate formula I ask the macro to create it looks as below:
=[NewCOST]NewCOST!A2&" ("&[NewCOST]NewCOST!E6&"x"&[NewCOST]NewCOST!E4&"g)"
I expect the formula to return text in the following format when R[-39]C[-1] = Cheese Cubes and R[-35]C[3] = 4 and R[-37]C[3] = 200
Cheese Cubes (4x200g)
I hope this all makes sense! Any help and advice would be greatly appreciated.
First, it is best to use the workbook and worksheet functions instead of select:
Dim wb as Workbook, ws as worksheet, nws as worksheet
Set wb = ActiveWorkbook
Set ws = wb.Worksheets("wsname")
set nws = wb.Worksheets("newws")'When you create new worksheet
Then you no longer need to use select when defining your range. Use:
ws.Range("...")
I would also try using the below for loop to interate through each cells formula, I would also write out the formula in excel and copy/paste in vba. Change the number with 'r':
For each r in Range("B" & NextFree)
'Formula here
Next r
I use two workbooks (obviously based on the question:)), from the first one (as you will see in the code below) gets sorted by the data in column "B". The data in this column is just a number based on the month (11=November, December=12, etc.). For this question (and it will provide the answer for my other monthly workbooks), need to copy all the rows of data (columns A:AE) in column B to another workbook (which is already open), and paste the data into the empty row at the bottom. I have the sort part working fine. I am trying to add in the copy & paste function into the code, but can't get it to work. HELP!
Here is the code I have tried (but can't figure out how to get focus to the target workbook):
Sub Extract_Sort_1512_December()
' This line renames the worksheet to "Extract"
Application.ScreenUpdating = False
ActiveSheet.Name = "Extract"
' This line autofits the columns C, D, O, and P
Range("C:C,D:D,O:O,P:P").Columns.AutoFit
' This unhides any hidden rows
Cells.EntireRow.Hidden = False
Dim LR As Long
With ActiveWorkbook.Worksheets("Extract").Sort
With .SortFields
.Clear
.Add Key:=Range("B2:B2000"), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
End With
.SetRange Range("A2:Z2000")
.Apply
End With
For LR = Range("B" & Rows.Count).End(xlUp).Row To 2 Step -1
If Range("B" & LR).Value <> "12" Then
Rows(LR).EntireRow.Hidden = True
End If
Next LR
Cells.WrapText = False
Sheets("Extract").Range("A2").Select
Dim LastRow As Integer, i As Integer, erow As Integer
LastRow = ActiveSheet.Range(“A” & Rows.Count).End(xlUp).Row
For i = 2 To LastRow
If Cells(i, 2) = “12” Then
Range(Cells(i, 1), Cells(i, 31)).Select
Selection.Copy
ActiveWorkbook(“Master File - Swivel - December 2015.xlsm”).Select
Worksheets(“Master”).Select
erow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
ActiveSheet.Cells(erow, 1).Select
ActiveSheet.Paste
End If
Next i
Application.ScreenUpdating = True
End Sub
I have found this code below, but do not know how to insert it properly into my code above. The thing that makes me weary is that the workbooks are already open. The target workbook is located on our SharePoint site and I do not know how (or if) you can use VBA code to open it to your desktop.
Here is the other code:
Sub Demo()
Dim wbSource As Workbook
Dim wbTarget As Workbook
' First open both workbooks :
Set wbSource = Workbooks.Open(" ") ' <<< path to source workbook
Set wbTarget = ActiveWorkbook ' Workbooks.Open(" ") ' <<< path to destination workbook
'Now, transfer values from wbSource to wbTarget:
wbTarget.Sheets("Sheet1").Range("B2").Value = wbSource.Sheets("Sheet3").Range("H4")
wbTarget.Sheets("Sheet1").Range("B3").Value = wbSource.Sheets("Sheet3").Range("J10")
'Close source:
wbSource.Close
End Sub
I have modified your code slightly, but kept most of it as is.
I think the problem was related to the way in which you were trying to activate the workbook where the data was to be pasted. Normally the Activate command is used with workbooks, as opposed to Select. However, I bypassed the whole activation of the new workbook, because it would require you to then "re-activate" the original workbook before copying the next line. Otherwise you would be copying from the active workbook, which would now be the one to be pasted into. Please see the code - it should be fairly straightforward.
Sub Extract_Sort_1512_December()
Application.ScreenUpdating = False
' This line renames the worksheet to "Extract"
ActiveSheet.Name = "Extract"
' This line autofits the columns C, D, O, and P
Range("C:C,D:D,O:O,P:P").Columns.AutoFit
' This unhides any hidden rows
Cells.EntireRow.Hidden = False
Dim LR As Long
With ActiveWorkbook.Worksheets("Extract").Sort
With .SortFields
.Clear
.Add Key:=Range("B2:B2000"), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
End With
.SetRange Range("A2:Z2000")
.Apply
End With
For LR = Range("B" & Rows.Count).End(xlUp).Row To 2 Step -1
If Not Range("B" & LR).Value = "12" Then
Rows(LR).EntireRow.Hidden = True
End If
Next LR
Cells.WrapText = False
Sheets("Extract").Range("A2").Select
Dim LastRow As Integer, i As Integer, erow As Integer
LastRow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To LastRow
If Cells(i, 2) = "12" Then
' As opposed to selecting the cells, I just copy them directly
Range(Cells(i, 1), Cells(i, 31)).Copy
' As opposed to "Activating" the workbook, and selecting the sheet, I just paste the cells directly
With Workbooks("Master File - Swivel - December 2015.xlsm").Sheets("Master")
erow = .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0).Row
.Cells(erow, 1).PasteSpecial xlPasteAll
End With
Application.CutCopyMode = False
End If
Next i
Application.ScreenUpdating = True
End Sub
I have a macro that compiles data from another worksheet and then manipulates said data. My first step is filtering by blanks and deleting all of the rows that appear. I thought I wrote the code correctly but I'm not apparently not, because each time I get a Run-time error '1004': Application-define or object-defined error
I don't see anything wrong with my variables, the column I'm filtering by is column D.
If you can see anything in my code that would help I'd love to know. Thank you!
Sub X50()
Dim wb As Workbook
Dim ws As Worksheet, macro As Worksheet, Pscrub As Worksheet
Dim lastRow As Long
Dim mlastRow As Long
Set wb = ThisWorkbook
Set ws = wb.Sheets("X50 - All")
lastRow = ws.Range("A" & Rows.Count).End(xlUp).Row
Sheets.Add After:=Sheets(Sheets.Count), Count:=2
Sheets(3).Select
Sheets(3).Name = "Pre Scrub"
Sheets(4).Select
Sheets(4).Name = "Macro"
Set Pscrub = wb.Sheets("Pre Scrub")
Set macro = wb.Sheets("Macro")
mlastRow = macro.Range("A" & Rows.Count).End(xlUp).Row
ws.Range("AM6:AM" & lastRow).Copy Destination:=macro.Range("A1")
ws.Range("AL6:AL" & lastRow).Copy Destination:=macro.Range("B1")
ws.Range("F6:F" & lastRow).Copy Destination:=macro.Range("C1")
ws.Range("E6:E" & lastRow).Copy Destination:=macro.Range("D1")
ws.Range("G6:G" & lastRow).Copy Destination:=macro.Range("E1")
ws.Range("K6:K" & lastRow).Copy Destination:=macro.Range("F1")
macro.Range("A1").AutoFilter Field:=4, Criteria1:=(""), _
Operator:=xlFilterValues
macro.Range("D2:D" & mlastRow).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
macro.AutoFilterMode = False
wsPrescrub.Range("$A$1:$F$" & mlastRow).RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5, 6) _
, Header:=xlYes
End Sub
This program is intended to be used to copy data from a pivot table on another sheet (varying number of rows for each data set). Each set of pasted data is used to create its own waterfall chart, for which I have templates already made on a different sheet.
There are a couple of issues I am having with this code.
1) For some reason, it no longer runs (I refactored the code from a macro) and gives me the error 'Compile Error: Sub or Function not defined'
- I've tried making a new module and a new macro but to no avail
2) Also, I want to change the range that the chart graphs based on the size of the data set. Here's what I have currently hardcoded:
Selection.Formula = "=SERIES(,Sheet5!R8C1:R17C1,Sheet5!R8C4:R17C4,1)"
So, Sheet5!R8C1:R17C1 would need to become SheetN!Start:End
Complete Code below:
Sub WF_New_Sheet()
Dim copyFrom As Range
Dim wS As Worksheet 'use as current worksheet
Dim cht As Chart
'Paste and format data
Set wS = Sheets("Pivot 1")
copyFrom = wSRange("C82:D90")
Set wS = Sheets.Add(After:=Worksheets.Count)
wS.Range("A9").Select
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False
Selection.Columns.AutoFit
Application.CutCopyMode = False
Range("A9", Range("B" & Rows.Count).End(xlUp).Address).sort Key1:=[b9], _
Order1:=xlAscending, Header:=xlNo 'sorts in 2 lines
Range("A8").Value = "Total"
Range("B8").Value = "=SUM(R[1]C:R[9]C)"
Dim rNum As Integer: rNum = Range("A9", Range("B" & Rows.Count).End(xlUp).Address).Rows.Count
'Paste data template and chart
copyFrom = Sheets("Sheet4").Range("D2:G15") 'sheet 4 is hardcoded and contains templates
wS.Range("D6").Resize(copyFrom.Rows.Count).Value = copyFrom.Value
Sheets("Sheet4").ChartObjects("Chart 1").Activate
Application.CutCopyMode = False
ActiveChart.ChartArea.Copy
wS.Range("I7").Select
ActiveSheet.Paste
ActiveSheet.ChartObjects("Chart 1").Activate
'Set appropriate ranges for chart data; format data for display
ActiveChart.SeriesCollection(2).Select
Selection.Formula = "=SERIES(,Sheet5!R8C1:R17C1,Sheet5!R8C5:R17C5,2)" 'How to make this dynamic?
ActiveChart.SeriesCollection(1).Select
Selection.Formula = "=SERIES(,Sheet5!R8C1:R17C1,Sheet5!R8C4:R17C4,1)" 'How to make this dynamic?
Range("B8").Value = "=SUM(R[1]C:R[9]C)*-1"
With Range("b9", "b17")
.Value = Evaluate(.Address & "*" & -1)
End With
End Sub
*edit code fixed to include sub and end sub
Figured out how to adjust the chart size. Added these lines:
Dim rowStart As Integer: rowStart = InputBox("Please enter starting row of your dataset.")
Dim rowEnd As Integer: rowEnd = InputBox("Please enter ending row of your dataset.")
Set copyFrom = Sheets("Pivot 1").Range(Sheets("Pivot 1").Cells(rowStart, colOne), Sheets("Pivot 1").Cells(rowEnd, colOne))
Set wS = Sheets.Add
wS.Move After:=Sheets(ActiveWorkbook.Sheets.Count)
wS.Range("A9").Resize(copyFrom.Rows.Count, copyFrom.Columns.Count).Value = copyFrom.Value
Set copyFrom = Sheets("Pivot 1").Range(Sheets("Pivot 1").Cells(rowStart, colTwo), Sheets("Pivot 1").Cells(rowEnd, colTwo))
wS.Range("B9").Resize(copyFrom.Rows.Count, copyFrom.Columns.Count).Value = copyFrom.Value