I have two Sheets , sheet1 called BW, and sheet 2 called reasons.
In sheet 1 I have columns AD till AW, which has to be added individually. i have table in sheet2, where I have listed the column names of AD till AW . in the second column of sheet 2 i Need the sum of column AD till AW. I tried a code like below
Sub sum()
Dim BWlRow As Long, CWlRow As Long, i As Long
Dim Sformula As String
Dim wsBW As Worksheet, wsCW As Worksheet
Set wsBW = Sheets("BW"): Set wsCW = Sheets("Reasons")
BWlRow = wsBW.Cells(wsBW.Rows.Count, "A").End(xlUp).Row
CWlRow = wsCW.Cells(wsCW.Rows.Count, "A").End(xlUp).Row
For i = 30 To 47 '
Sformula = "=SUM(AD2, BW)"
With wsBW
With .Range(.Cells(2, i), .Cells(BWlRow, i))
.Formula = Sformula
.Value = .Value
End With
End With
Next i
End Sub
I am not able to succeed with this.
Assumptions:
Sheets("BW") is the sheet why you have data from Column AD-AW
In Sheets("Reasons") Column A you have listed down the headers of Sheets("BW") Column AD-AW in same order, so there's no need to match for the headers
You want sum of corresponding Sheets("Reasons") Column A items in Sheets("Reasons") Column B
Last row of each sheet is on the basis of number of records in Column A of both sheets
Sub sum()
Dim BWlRow As Long, CWlRow As Long, i As Long
Dim Sformula As String
Dim wsBW As Worksheet, wsCW As Worksheet
Set wsBW = Sheets("BW"): Set wsCW = Sheets("Reasons")
BWlRow = wsBW.Cells(wsBW.Rows.Count, "A").End(xlUp).Row
CWlRow = wsCW.Cells(wsCW.Rows.Count, "A").End(xlUp).Row
Sformula = "=SUM(INDIRECT(""BW!"" & CELL(""address"",OFFSET(AD$2,0,ROW()-2)) & "":"" & CELL(""address"",OFFSET(AD$10,0,ROW()-2))))"
With wsCW
With .Range(.Cells(2, 2), .Cells(CWlRow, 2))
.Formula = Sformula
.Value = .Value
End With
End With
End Sub
Related
I have 2 sheets. Sheet1 has 2 rows: column names and values.
Sheet 2 is a master sheet with all the possible column names in. I need to copy the values from sheet 1 into their appropriate column.
I think i can do this via a match function, and so far i have this:
Sub dynamic_paste()
Dim Columnname As String
Dim inputvalue As String
Dim starter As Integer
Dim i As Integer
starter = 0
For i = 1 To 4
'replace 4 with rangeused.rows.count?
Sheets("sheet1").Select
Range("a1").Select
ActiveCell.Offset(0, starter).Select
Columnname = ActiveCell
'sets columnname variable
ActiveCell.Offset(1, 0).Select
inputvalue = ActiveCell
'sets inputname variable
Sheets("sheet2").Select
'**Cells(0, WorksheetFunction.Match(Columnname, Rows(1), 0)).Select**
Range("a1").Offset(1, starter).Value = inputvalue
'inputs variable in the next cell along
starter = starter + 1
Next
End Sub
I need to find out how to use my columnname variable as the matching value, and then offset down to the first row that is empty - then change the value of that cell to the variable called inputvalue.
For extra points: I need to make sure the code doesnt break if they dont find a matching value, and if possible put any values that dont match into the end of the row?
What about this:
Dim LR As Long, X As Long, LC As Long, COL As Long
Dim RNG As Range, CL As Range
Option Explicit
Sub Test()
LR = Sheets(2).Cells.SpecialCells(xlCellTypeLastCell).Row 'Get last used row in your sheet
LC = Sheets(2).Cells(1, Sheets(2).Columns.Count).End(xlToLeft).Column 'Get last used column in your sheet
Set RNG = Sheets(2).Range(Sheets(2).Cells(1, 1), Sheets(2).Cells(1, LC))
'Loop through all the columns on your sheet with values
For X = 1 To Sheets(1).Cells(1, Sheets(1).Columns.Count).End(xlToLeft).Column
Set CL = RNG.Find(Sheets(1).Cells(1, X).Value, lookat:=xlWhole)
If Not CL Is Nothing Then
COL = CL.Column
Sheets(2).Cells(LR + 1, COL).Value = Sheets(1).Cells(2, X).Value 'Get the value on LR offset by 1
Else
Sheets(2).Cells(1, Sheets(2).Cells(1, Sheets(2).Columns.Count).End(xlToLeft).Column).Value = Sheets(1).Cells(1, X).Value
Sheets(2).Cells(LR + 1, Sheets(2).Cells(1, Sheets(2).Columns.Count).End(xlToLeft).Column).Value = Sheets(1).Cells(2, X).Value
End If
Next X
End Sub
This way you will avoid using select. Which is very recommandable!
This is Sheet1:
This is Sheet2:
This is the code:
Option Explicit
Sub DynamicPaste()
Dim col As Long
Dim wks1 As Worksheet: Set wks1 = Worksheets(1)
Dim wks2 As Worksheet: Set wks2 = Worksheets(2)
For col = 1 To 3
Dim currentRow As Long
currentRow = WorksheetFunction.Match(wks2.Cells(1, col), wks1.Columns(1))
wks2.Cells(2, col) = wks1.Cells(currentRow, 2)
Next col
End Sub
This is Sheet2 after the code:
This is a must-read - How to avoid using Select in Excel VBA
I am trying to match an ID cell from sheet 1 to and ID cell in sheet 2. If these match then I need to match a product cell from sheet 1 to a product cell in sheet two.
The ID cell in sheet 1 has multiples of the same ID in a column with different products in the next cell (column A = ID, column B = product).
In sheet 2 there is only one instance of each ID, however the product goes across the row. If the two criteria match, I need a 1 to be placed in the cell below the product.
This needs to be looped across the row and once the row finishes, move to the next ID in sheet 1. If the criteria do not match then the cell needs to be filled with a 0.
The trouble I am have is moving to the next ID. I have included the code and appreciate any help.
Public Sub test()
Dim ws As Worksheet, sh As Worksheet
Dim wsRws As Long, dataWsRws As Long, dataRng As Range, data_Rng As Range, data_cell As Range, datacell As Range
Dim shRws As Long, prodShRws As Long, resRng As Range, res_Rng As Range, results_cell As Range, product_cell As Range, shCols As Long
Set dataSht = Sheets("Device Import")
Set resSht = Sheets("Transform Pivot")
With dataSht
wsRws = .Cells(.Rows.Count, "A").End(xlUp).Row
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
dataWsRws = .Cells(.Rows.Count, "B").End(xlUp).Row
Set dataRng = .Range(.Cells(2, "A"), .Cells(wsRws, "A"))
Set data_Rng = .Range(.Cells(2, "B"), .Cells(wsRws, "B"))
End With
With resSht
shRws = .Cells(Rows.Count, "A").End(xlUp).Row
shCols = .Cells(1, Columns.Count).End(xlToLeft).Column
Set resRng = .Range(.Cells(2, "A"), .Cells(shRws, "A"))
Set res_Rng = .Range(.Cells(1, "B"), .Cells(1, shCols))
End With
i = 1
For Each data_cell In dataRng 'data sheet
For Each product_cell In res_Rng 'results sheet
For Each datacell In data_Rng 'data sheet
For Each results_cell In resRng 'results range
If data_cell = results_cell And datacell = product_cell Then
MsgBox data_cell.Value + " " + datacell.Value
results_cell.Offset(0, i) = 1 ' dcell = rcell so recell offset = 1
Else
MsgBox product_cell.Value + " " + results_cell.Value
results_cell.Offset(0, i) = 0 ' no match so rcell offset = 0
End If
If results_cell = "" Then
Exit For
End If
i = i + 1
Next results_cell ' Results ID column
i = 1
Exit For
Next datacell ' Data Product column cell
Next product_cell ' Results ID row
Next data_cell ' Data ID column cell
End Sub
An alternative approach would be
Initialize the resSht to 0's first
Loop only the dataSht looking at each ID Product pair
Use match to find the ID and product on resSht and fill in 1's as found
Public Sub Demo()
Dim dataSht As Worksheet, resSht As Worksheet
Dim rData As Range
Dim rwRes As Variant, clRes As Variant
Dim colResID As Long, rwResProd As Long
colResID = 1 '<-- Column in Result Sheet containing ID
rwResProd = 1 '<-- Row in Result Sheet containing Products
Set dataSht = Sheets("Device Import")
Set resSht = Sheets("Transform Pivot")
'Initialise to 0
With resSht
.Range(.Cells(rwResProd, .Columns.Count).End(xlToLeft).Offset(1, 0), _
.Cells(.Rows.Count, colResID).End(xlUp).Offset(0, 1)) = 0
End With
' Lookup each ID and Product pair from dataSht in resSht
With dataSht
For Each rData In .Range(.Cells(2, 1), .Cells(.Rows.Count, 1).End(xlUp))
rwRes = Application.Match(rData.Value2, resSht.Columns(colResID), 0)
If Not IsError(rwRes) Then
clRes = Application.Match(rData.Offset(0, 1).Value2, resSht.Rows(rwResProd), 0)
If Not IsError(clRes) Then
resSht.Cells(rwRes, clRes) = 1
Else
MsgBox "Product " & rData.Offset(0, 1).Value2 & " not found in Result Sheet", vbOKOnly + vbExclamation, "Missing Product"
End If
Else
MsgBox "ID " & rData.Value2 & " not found in Result Sheet", vbOKOnly + vbExclamation, "Missing ID"
End If
Next
End With
End Sub
Example Result
I am very new to VBA. Just started reading it up 2 days ago. I am wondering how could I write a VB codes assigned to a button to read through the whole column and search for similar numbers.
After that identifying similar numbers, it would need to move on to another column to check if the character in the column are same too.
If both of the logic = true . How can i change the cell of the value of another column?
Sample data
For the current example. The code should know that the first column had matching numbers. After that it will check for the name which is "a" in the example. After that it will automatically change the point to 1 and 0. If there are 3 same ones it will be 1,0,0 for the point
You may try recording whatever you want to do with record macros first, then filter out the codes that are not necessary. If you do not know how to record it using macros, click on the link below. You can learn from the recorded macros and slowly improvise your codes in the future from the experience you may gain.
Here's [a link] (http://www.dummies.com/software/microsoft-office/excel/how-to-record-a-macro-in-excel-2016/)
As per image attached in image I am assuming numbers are in Column A, column to check characters is Column J and result needs to be displayed in Column O then try following code.
Sub Demo()
Dim dict1 As Object
Dim ws As Worksheet
Dim cel As Range, fCell As Range
Dim lastRow As Long, temp As Long
Dim c1
Set dict1 = CreateObject("Scripting.Dictionary")
Set ws = ThisWorkbook.Sheets("Sheet2") 'change Sheet2 to your data sheet
With ws
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row 'last row with data in Column A
c1 = .Range("A2:A" & lastRow)
For i = UBound(c1, 1) To 1 Step -1 'enter unique values with corresponding values in dict1
dict1(c1(i, 1)) = .Range("J" & i + 1) '+1 for Row 2
Next i
Set fCell = .Range("A2")
For Each cel In .Range("A2:A" & lastRow) 'loop through each cell in Column A
temp = WorksheetFunction.CountIf(.Range(fCell, cel.Address), cel) 'get count
If temp > 1 Then
If cel.Offset(0, 9) = dict1(cel.Value) Then
cel.Offset(0, 14).Value = 0
Else
cel.Offset(0, 14).Value = 1
End If
Else
cel.Offset(0, 14).Value = 1
End If
Next cel
End With
End Sub
EDIT
Sub Demo()
Dim ws As Worksheet
Dim lastRow As Long
Application.ScreenUpdating = False
Set ws = ThisWorkbook.Sheets("Sheet2") 'change Sheet3 to your data range
With ws
lastRow = .Cells(.Rows.count, "A").End(xlUp).Row 'last row with data in Column A
.Range("O2").Formula = "=IF(MOD(SUMPRODUCT(($A$2:$A2=A2)*($J$2:$J2=J2)),3)=1,1,0)" 'enter formula in Cell O2
.Range("O2").AutoFill Destination:=.Range("O2:O" & lastRow) 'drag formula down
.Range("O2:O" & lastRow).Value = .Range("O2:O" & lastRow).Value 'keep only values
End With
Application.ScreenUpdating = True
End Sub
I have two Sheets , sheet1 and sheet2 .
Sheet1 has 27 columns, and sheet2 has 10 columns,
I am looking for the Id in sheet 1, column J and Need the corresponding date in sheet 2 , column g.
I Need this corresponding date to be printed in sheet 1 , column AA.
I am using the following belo VBA, it is printing the column D of sheet 2 insted of Column G.
This is the formula,
=IFERROR(VLOOKUP(j2;sheet2!$A:$L;7;0);"")
I dont want to use, record macro functionality. Kindly, help me to correct the code.
Sub lookup()
Dim totalrows As Long
Dim totalcolumn As Long
Dim rng As Range
Dim rng1 As Range
Dim i As Long
totalrows = ActiveSheet.UsedRange.Rows.Count
For i = 2 To totalrows
Sheets("Sheet1").Select
Set rng = Sheets("Sheet2").UsedRange.Find(Cells(i, 10).Value)
If Not rng Is Nothing Then
Cells(i, 27).Value = rng.Value
End If
Next i
End Sub
Instead of FOR loop you can use:
Sheets("Sheet1").Range("AA2:AA" & totalrows).Formula = Application.WorksheetFunction.IfError(Application.VLookup(Sheets("Sheet1").Range("J2:J15"), Sheets("Sheet2").Range("$A:$L"), 7, 0), "")
EDIT:_____________________________________________________________________________
Sub lookup()
Dim totalrows As Long, totalrowsSht2 As Long
totalrows = Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Row
totalrowsSht2 = Sheets("Sheet2").Cells(Rows.Count, "A").End(xlUp).Row
Sheets("Sheet1").Range("AA2:AA" & totalrows).Formula = Application.WorksheetFunction.IfError(Application.VLookup(Sheets("Sheet1").Range("J2:J" & totalrowsSht2), Sheets("Sheet2").Range("$A:$L"), 7, 0), "")
End Sub
I have the following data set in Sheet1 with headings as you see below:
I want to split the big data set into different sheets by every empty row. Every data set is separated by an empty row, and every data set have values in all cells in columns A and E but their columns B, C, D might have some empty cells randomly. So the defining element to split is the empty rows in column E.
Q1: I want to copy the headings A1:D1 to the new sheets and only copy the columns A:D and not the column E.
Q2: I want to rename new sheets to take the cell value in column E as their name.
So the *results are the following:
Sheet ID1:
Sheet ID2:
Sheet ID3:
I have tried the following code, it works, but it only copies the first table, without renaming the sheet to take the cell value in column E, and it should copy the column E so it should copy only A:D, and it doesn't loop through all tables.
Sub Split_Sheets_by_row()
Dim lLoop As Long, lLoopStop As Long
Dim rMove As Range, wsNew As Worksheet
Set rMove = ActiveSheet.UsedRange.Columns("A:E")
lLoopStop = WorksheetFunction.CountIf(rMove, "Heading5")
For lLoop = 1 To lLoopStop
Set wsNew = Sheets.Add
rMove.Find("Heading5", rMove.Cells(1, 1), xlValues, _
xlPart, , xlNext, False).CurrentRegion.Copy _
Destination:=wsNew.Cells(1, 1)
Next lLoop
End Sub
Your help is very much appreciated.
I've taken a slightly different approach but I have achieved the results you are looking for.
Sub Split_Sheets_by_row()
Dim hdr As Range, rng As Range, ws As Worksheet, wsn As Worksheet
Dim rw As Long, lr As Long, b As Long, blks As Long
Set ws = ActiveSheet
With ws
Set hdr = .Cells(1, 1).Resize(1, 4)
lr = .Cells(Rows.Count, 5).End(xlUp).Row
rw = 2
blks = Application.CountBlank(.Range(.Cells(rw, 1), .Cells(lr, 1))) + 1
For b = 1 To blks
Set rng = .Cells(rw, 1).CurrentRegion
Set rng = rng.Offset(-CBool(b = 1), 0).Resize(rng.Rows.Count + CBool(b = 1), 4)
Set wsn = Worksheets.Add(after:=Sheets(Sheets.Count))
With wsn
.Name = rng.Offset(0, 4).Cells(1, 1).Value
hdr.Copy Destination:=.Cells(1, 1)
rng.Copy Destination:=.Cells(2, 1)
End With
rw = rw + rng.Rows.Count + 1
Set rng = Nothing
Set wsn = Nothing
If rw > lr Then Exit For
Next b
End With
Set rng = Nothing
Set ws = Nothing
End Sub
The header is stored for repeated use and the number of blocks of data are counted by counting the separating blank rows and adding 1. The value from column E is used to rename the worksheet but is not carried across in the data transfer to the new worksheet.
I'm not sure how you would want to handle a worksheet with the same name already existing but they could be deleted before a new worksheet is renamed.