I have 2 sheets, shown below
What I would like to do is, write a VBA subroutine that:
look for all instances of sheet 2 column A from sheet 1 column A,
then replace the corresponding sheet 1 column D with sheet 2 column B
Greatly appreciate your help.
You may give this a try...
Sub CompareAndReplaceData()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim lr As Long, i As Long
Dim Rng As Range, Cell As Range
Dim x, dict
Application.ScreenUpdating = False
Set ws1 = Sheets("Sheet1")
Set ws2 = Sheets("Sheet2")
lr = ws1.Cells(Rows.Count, 1).End(xlUp).Row
Set Rng = ws1.Range("A2:A" & lr)
x = ws2.Range("A1").CurrentRegion.Value
Set dict = CreateObject("Scripting.Dictionary")
For i = 2 To UBound(x, 1)
dict.Item(x(i, 1)) = x(i, 2)
Next i
For Each Cell In Rng
If dict.exists(Cell.Value) Then
ws1.Cells(Cell.Row, "D") = dict.Item(Cell.Value)
End If
Next Cell
Application.ScreenUpdating = True
End Sub
Related
my goal is to copy cells in a dynamic range from Column B to S to another sheet if they are non zero. Additionally, would like to move the cells up to the top of the next sheet (Without having to clear blank rows each time). Have the code working for 1 column (when Col was replaced with "B", "C", etc.) but when I tried to make it a for loop of multiple it doesnt work.
Any help would be appreciated!
Sub MoveFormulaDataLooped()
Dim ws1 As Worksheet: Set ws1 = Worksheets("Fancy Wall")
Dim ws2 As Worksheet: Set ws2 = Worksheets("Sheet1")
Dim VeryLastRow As Integer: VeryLastRow = ws1.Cells(ws1.Rows.Count, 1).End(xlUp).Row
Dim i As Integer
Dim Col As Integer
For i = 2 To VeryLastRow
For Col = 2 To 19
If ws1.Range(Col & i) > 0 Then
ws2.Range(Col & i) = ws1.Range(Col & i)
Next
Next
End Sub
A few notes:
You are looking for the property .Cells instead of .Range, as it uses row and column index to access your range.
You are missing an End If in you most inner conditional
You need to capture the next row for your ws2 so that you don't have blanks between them
I included a function that helps you find the next available row, and made the fixes from my notes above.
' Finds the next empty row on a worksheet.
Public Function NextAvailibleRow(ByRef ws As Worksheet) As Range
On Error GoTo catch
Set NextAvailibleRow = ws.Cells.Find("*", , xlValues, , xlRows, xlPrevious).Offset(1).EntireRow
Exit Function
' If there is an error, that means the worksheet is empty.
' Return the first row
catch:
Set NextAvailibleRow = ws.Rows(1)
End Function
Sub MoveFormulaDataLooped()
Dim ws1 As Worksheet: Set ws1 = Worksheets("Fancy Wall")
Dim ws2 As Worksheet: Set ws2 = Worksheets("Sheet1")
Dim VeryLastRow As Integer
VeryLastRow = ws1.Cells(ws1.Rows.Count, 1).End(xlUp).Row
Dim i As Integer
For i = 2 To VeryLastRow
' Need to capture the next row for Sheet1
Dim nextSheet1Row As Long
nextSheet1Row = NextAvailibleRow(ws2).Row
Dim Col As Integer
For Col = 2 To 19
If ws1.Cells(i, Col) > 0 Then
' Use `.Cells`
ws2.Cells(nextSheet1Row, Col) = ws1.Cells(i, Col)
End If ' Was missing
Next
Next
End Sub
I am trying to develop a loop in VBA Excel which copy and paste first column from Pivot table as many times as the number of all the columns in this Pivot table (if I have 62 columns I need to copy paste the first column 61 times in one column in another sheet2). I need to copy the other 61 columns into one column together with the header of each column in third column in sheet2.
Sub SelCopCol()
Dim ss As String
Dim wb As Workbook
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim i As Long
Dim NC As Long
Set wb = ThisWorkbook
Set ws1 = wb.Worksheets(sheet1_Pivot)
Set ws2 = wb.Worksheets(sheet2)
'Define the range of rows
ss = ws1.Range("A:A").Find("Grand Total", ws1.Cells(1, 1)).Row
NC = ws1.Cells(1, Columns.Count).End(xlToLeft).Column
Application.ScreenUpdating = False
For i = 2 To NC
ws2.Range("C2:C" & ss - 1) = ws1.Range("A2:A" & ss - 1).Value
ws2.Range("H2:H" & ss - 1) = ws1.Range("B2:B" & ss - 1).Value
ws2.Range("M2:M" & ss - 1) = ws1.Range("B1").Value
'I should use a variables for "B2:B" and "B1" but I couldn't
Next i
Application.ScreenUpdating = True
End Sub
Here's one way:
Sub SelCopCol()
Dim ss As Long '<< not string
Dim wb As Workbook
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim numRows As Long, NC As Long, rng As Range, rng2 As Range, rngDest As Range
Set wb = ThisWorkbook
Set ws1 = wb.Worksheets("sheet1_Pivot")
Set ws2 = wb.Worksheets("sheet2")
NC = ws1.Cells(1, Columns.Count).End(xlToLeft).Column
ss = ws1.Range("A:A").Find("Grand Total", ws1.Cells(1, 1)).Row
Set rng = ws1.Range("A2:A" & ss - 1) 'row labels
numRows = rng.Rows.Count
Set rng2 = rng.Offset(0, 1) 'first data column
Set rngDest = ws2.Range("C2").Resize(numRows) 'first "paste" destination
Application.ScreenUpdating = False
Do While rng2.Column <= NC 'until we reach the last column
'copy values
rngDest.Value = rng.Value
rngDest.EntireRow.Columns("H").Value = rng2.Value
rngDest.EntireRow.Columns("M").Value = ws1.Cells(1, rng2.Column).Value
Set rng2 = rng2.Offset(0, 1) 'one column over
Set rngDest = rngDest.Offset(numRows) 'move destination range down
Loop
Application.ScreenUpdating = True
End Sub
I have a worksheet with sales data, I've managed to create Autofilter based on department and copied the results into the new sheet (Output). What I'm trying to achieve is that code will multiply the results of respective month by value in "Adjustment" row.
So the result is following
Is there a way how to process calculations within my code or I shall multiply each column in different Sub afterwards?
Dim Last_Row As Long
Dim DbExtract, DuplicateRecords As Worksheet
Dim WKS2 As Worksheet
Dim rn As Range
Set DbExtract = ThisWorkbook.Sheets("Data")
Set DuplicateRecords = ThisWorkbook.Sheets("Output")
Set WKS2 = ThisWorkbook.Sheets("Dashboard")
iMultiplier = WKS2.Range("Z18")
Application.ScreenUpdating = False
Last_Row = DuplicateRecords.Range("A" & Rows.Count).End(xlUp).Row + 1
DbExtract.Range("C3:R1500").SpecialCells(xlCellTypeVisible).Copy
DuplicateRecords.Range("A" & Last_Row).PasteSpecial
DuplicateRecords.Range("$A$1:$P$400").AutoFilter Field:=3, Criteria1:=WKS2.Range("V2")
Set rn = DuplicateRecords.Range("G2:G500").SpecialCells(xlCellTypeVisible)
For Each cell In rn
iNewnumber = cell * iMultiplier
Next cell
End Sub
Here's an example:
Sub Tester()
Dim lastRow As Long, wb As Workbook
Dim wsData As Worksheet, wsOutput As Worksheet
Dim wsDash As Worksheet, rngVis As Range, numVisRows As Long
Dim rn As Range, rngAdj As Range, m As Long, adj, c As Range
Set wb = ThisWorkbook
Set wsData = wb.Sheets("Data") 'consistent naming helps...
Set wsOutput = wb.Sheets("Output")
Set wsDash = wb.Sheets("Dashboard")
'iMultiplier = wsDash.Range("Z18") '?
Application.ScreenUpdating = False
Set rngVis = wsData.Range("C3:R1500").SpecialCells(xlCellTypeVisible)
numVisRows = rngVis.Cells.Count / rngVis.Columns.Count
rngVis.Copy
lastRow = wsOutput.Range("A" & Rows.Count).End(xlUp).Row + 1 'start of pasted data
wsOutput.Range("A" & lastRow).PasteSpecial
Set rngAdj = wsDash.Range("C5:N5") 'for example
For m = 1 To rngAdj.Columns.Count 'loop the cells in the adjustments range
adj = rngAdj.Cells(m).Value 'adjustment value
If Len(adj) > 0 And IsNumeric(adj) Then 'have an adjustment to make?
'loop the relevant cells in the pasted data
For Each c In wsOutput.Cells(lastRow, "A").Offset(0, 2 + m).Resize(numVisRows).Cells
If Len(c.Value) > 0 And IsNumeric(c.Value) Then 'any thing to adjust?
c.Value = c.Value * adj
End If
Next c
End If
Next m
End Sub
I have data in a table, where I compare two columns J and T. The values which J and T can take include A2B, APL, BGF, CMA, among others (see code).
If these values are equal, copy row i into the sheet which has the name of the cells just checked.
If these values are not equal, copy row i into the sheets which have the name of the cells just checked.
Example: Compare J2 and T2,
Suppose J2=T2=BGF then copy row 2 and paste into sheet("BGF")
Next, compare J3 and T3
Suppose J3=BGF and T3=CMA, copy row 3 and paste into sheet(BGF) and sheet(CMA)
Next, compare J4 and T4
Suppose J4=Nothing and T4=CMA, copy row 4 and paste into sheet CMA
the only other combination is where Ji has a value and Ti is empty.
Problem: When running this code, If J3=BGF and T3= nothing (its empty), then the line is not copied to any sheet.
Here's the code
Sub Sortdata()
'step 1 clear all data
Sheets("A2B").Cells.ClearContents
Sheets("APL").Cells.ClearContents
Sheets("BGF").Cells.ClearContents
Sheets("CMA").Cells.ClearContents
Sheets("K Line").Cells.ClearContents
Sheets("MacAndrews").Cells.ClearContents
Sheets("Maersk").Cells.ClearContents
Sheets("OOCL").Cells.ClearContents
Sheets("OPDR").Cells.ClearContents
Sheets("Samskip").Cells.ClearContents
Sheets("Unifeeder").Cells.ClearContents
Dim i As Long
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim LastRow As Long
With Worksheets("All Data")
LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
For i = 2 To LastRow
If IsEmpty(.Range("J" & i)) Then
Set ws1 = Nothing
Else
Set ws1 = Worksheets(.Range("J" & i).Value)
End If
If IsEmpty(.Range("T" & i)) Then
Set ws2 = Nothing
Else
Set ws2 = Worksheets(.Range("T" & i).Value)
End If
If ws1 Is Nothing Then
If Not ws2 Is Nothing Then
CopyToWs ws2, .Rows(i)
End If
ElseIf ws2 Is Nothing Then
If Not ws1 Is Nothing Then
CopyToWs ws1, .Rows(i)
End If
Else
CopyToWs ws1, Rows(i)
If ws1.Name <> ws2.Name Then
CopyToWs ws2, .Rows(i)
End If
End If
Next
End With
End Sub
Sub CopyToWs(ws As Worksheet, rng As Range)
rng.Copy
ws.Cells(ws.Rows.Count, 1).End(xlUp).Offset(1, 0).EntireRow.PasteSpecial xlPasteValuesAndNumberFormats
End Sub
Please try this code. It takes a slightly different approach to what you tried but it gets the job done, I think.
Option Explicit
Sub Sortdata()
' Variatus #STO 20 Jan 2020
Const WsNames As String = "A2B,APL,BGF,CMA,K Line,MacAndrews," & _
"Maersk,OOCL,OPDR,Samskip,Unifeeder"
Dim WsS As Worksheet ' Source
Dim Ws As Worksheet
Dim Rng As Range
Dim Rt As Long ' target row
Dim LastRow As Long
Dim J As Long, T As Long
Dim Tmp As Variant, PrevTmp As Variant
Dim R As Long, C As Long
'step 1 clear all data
Tmp = Split(WsNames, ",")
For R = LBound(Tmp) To UBound(Tmp)
On Error Resume Next
Worksheets(Tmp(R)).Cells.ClearContents
Next R
Application.ScreenUpdating = False
Set WsS = Worksheets("All Data")
With WsS
J = .Columns("J").Column
T = .Columns("T").Column
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
For R = 2 To LastRow
PrevTmp = ""
For C = J To T Step T - J
Tmp = .Cells(R, C).Value
If Len(Tmp) And Tmp <> PrevTmp Then
On Error Resume Next
Set Ws = Worksheets(Tmp)
If Err = 0 Then
Set Rng = .Range(.Cells(R, 1), .Cells(R, .Columns.Count).End(xlToLeft))
With Ws
Rt = Application.Max(.Cells(.Rows.Count, "A").End(xlUp).Row + 1, 2)
Rng.Copy Destination:=Ws.Cells(Rt, 1)
End With
End If
End If
PrevTmp = Tmp
Next C
If R Mod 25 = 0 Then Application.StatusBar = "Currently processing row " & R
Next R
End With
With Application
.ScreenUpdating = True
.StatusBar = "Done"
End With
End Sub
I think you will be able to find your way through it and make any required modifications. Let me know if you require any assistance.
I have a workbook with a series of sheets that I need to run a code to resolve the data.
I have one worksheet with a list of "codes" and another sheet that has cells that will include a string of codes.
I am trying to create a macro that allows me to reference a code in sheet1 A1, and then look through B:B in sheet2 and copy the row if the code appears in the string
I am a novice VBA user and have tried googling a few things and I'm not having any luck.
Edit:
I have managed to get something that does copy the data through, but there seems to be an issue in the For loop as all lines are copied in, not just the lines that match. Code below.
Private Sub CommandButton1_Click()
Dim xRg As Range
Dim xCell As Range
Dim I As Long
Dim J As Long
Dim K As Long
I = Worksheets("MASTER LIST").UsedRange.Rows.Count
J = Worksheets("VALIDATED LIST").UsedRange.Rows.Count
If J = 1 Then
If Application.WorksheetFunction.CountA(Worksheets("VALIDATED LIST").UsedRange) = 0 Then J = 0
End If
Set xRg = Worksheets("MASTER LIST").Range("E1:E" & I)
On Error Resume Next
Application.ScreenUpdating = True
For K = 1 To xRg.Count
If CStr(xRg(K).Value) = InStr(Worksheets("MASTER LIST").Range("E1:E" & I).Value, Worksheets("TRANSPOSED DATA NO SPACES").Range("B1:B" & J)) > 1 Then
xRg(K).EntireRow.Copy Destination:=Worksheets("VALIDATED LIST").Range("A" & J + 1)
J = J + 1
End If
Next
Application.ScreenUpdating = True
End Sub
Further Edit:
I want to be able to use the list of feature codes and look them up in the master list.
If the VBA code finds the feature code in the strings in the master list, then I need to copy the row and paste it into a blank sheet that will be called validated list.
Sub look_up_copy()
Dim last_row As Integer
Dim cell As Range
Dim Cells As Range
last_row = ThisWorkbook.Worksheets(2).Cells(ThisWorkbook.Worksheets(2).Rows.Count, "B").End(xlUp).Row
Set Cells = ThisWorkbook.Worksheets(2).Range("B1:B" & last_row)
For Each cell In Cells:
If cell.Value = ThisWorkbook.Worksheets(1).Range("A1").Value Then
cell.EntireRow.Copy
End If
Next cell
End Sub
You didn't say anything about wanting to paste, but if you do then just insert it after the copy line.
this should work, just remove duplicates on sheet3 after running. This is a double loop in which, for each cell in column B of sheet 2, the macro will check all values from sheet1 Column A. You will see duplicate lines in the end, but it doesn't matter right? all you need is remove dupes
Sub IvanAceRows()
Dim cell2 As Range, cells2 As Range, cell1 As Range, cells1 As Range
Dim lastrow2 As Long, lastrow1 As Long
Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
Dim i As Long, ii As Long, iii As Long
Set ws1 = Worksheets("USAGE CODES")
Set ws2 = Worksheets("MASTER LIST")
Set ws3 = Worksheets("VALIDATED LIST")
lastrow1 = ws1.cells(Rows.Count, 1).End(xlUp).Row
lastrow2 = ws2.cells(Rows.Count, 2).End(xlUp).Row
Set cells1 = ws1.Range("A1:A" & lastrow1)
Set cells2 = ws2.Range("B1:B" & lastrow2)
iii = 1
For ii = 1 To lastrow2
For i = 1 To lastrow1
If InStr(1, ws2.cells(ii, 2), ws1.cells(i, 1)) <> 0 Then
ws2.cells(ii, 2).EntireRow.Copy
ws3.Activate
ws3.cells(iii, 1).Select
Selection.PasteSpecial
iii = iii + 1
End If
Next i
Next ii
End Sub
Without seeing your spreadsheet, I assumed all of your 'codes' are listed in Column A in sheet1, and all of those code strings are also in sheet2 in column B. my code allows u to find each string from sheet1 in Column B of sheet2. Once found, it will be pasted into Sheet3 starting from the 2nd row.
Sub IvanfindsRow()
Dim i As Long
Dim lastrow1 As Long
Dim lastrow2 As Long
Dim Code As String
Dim search As Range
lastrow1 = Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
lastrow2 = Worksheets("Sheet2").Cells(Rows.Count, 2).End(xlUp).Row
Worksheets("Sheet3").Range("A1").Select
For i = 1 To lastrow1
Code = Worksheets("Sheet1").Cells(i, 1).Value
Set search = Worksheets("Sheet2").Range("B1:B22").Find(what:=Code, lookat:=xlWhole)
If Not search Is Nothing Then
search.EntireRow.Copy
ActiveCell.Offset(1, 0).Select
Selection.PasteSpecial
Else 'do nothing
End If
Next i
Application.CutCopyMode = False
End Sub