I am trying to extract data from source sheet into a master sheet.
If there is any existing record in the master sheet, update the record in the master sheet with the latest data from source sheet.
Otherwise add the data from source sheet into the master sheet.
I pieced together code for one customer (single sheet).
How could I modify it to allow updating of multiple sheets?
I understand I need looping of worksheets but I am hitting errors.
Sub Update()
Dim wsSrc As Worksheet, wsDest As Worksheet, i As Integer, j As Integer, k As Integer, srcLastRow As Long, destLastRow As Long, srcFndVal As String, destFndCell As Range, srcValRow As Long, destValRow As Long, destFndVal As String, srcFndCell As Range
Application.ScreenUpdating = False
Set wsSrc = Worksheets("Cust A")
Set wsDest = Worksheets("Master")
srcLastRow = wsSrc.Cells(Rows.Count, "BA").End(xlUp).Row
destLastRow = wsDest.Cells(Rows.Count, "A").End(xlUp).Row
j = wsDest.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).Row
With wsDest
For i = 4 To srcLastRow
srcFndVal = wsSrc.Cells(i, "AA")
Set destFndCell = .Range("A:A").Find(srcFndVal, LookIn:=xlValues)
If destFndCell Is Nothing And wsSrc.Cells(i, "AA").Value <> "" Then
.Range("A" & j & ":F" & j).Value = wsSrc.Range("AA" & i & ":AF" & i).Value
.Range("J" & j & ":K" & j).Value = wsSrc.Range("AG" & i & ":AH" & i).Value
.Range("G" & j & ":H" & j).Value = wsSrc.Range("AE" & i & ":AF" & i).Value
j = j + 1
Else
srcValRow = wsSrc.Range("AA:AA").Find(what:=srcFndVal, after:=wsSrc.Range("AA4"), LookIn:=xlValues).Row
destValRow = wsDest.Range("A:A").Find(what:=srcFndVal, after:=wsDest.Range("A4"), LookIn:=xlValues).Row
.Range("B" & destValRow & ":F" & destValRow).Value = wsSrc.Range("AB" & srcValRow & ":AF" & srcValRow).Value
.Range("J" & destValRow & ":K" & destValRow).Value = wsSrc.Range("AG" & srcValRow & ":AH" & srcValRow).Value
End If
Next
For k = 4 To destLastRow
destFndVal = wsDest.Cells(k, "A")
Set srcFndCell = wsSrc.Range("AA:AA").Find(destFndVal, LookIn:=xlValues)
If srcFndCell Is Nothing And wsDest.Cells(k, "A").Value <> "" Then
.Range("B" & k & ":F" & k).Value = vbNullString
End If
Next
End With
Application.ScreenUpdating = True
End Sub
I modified the code to loop through the worksheets in an array however there is an issue with getting the last row of the wsSrc.
>Run-time error 424 Object required.
Below line is highlighted
srcLastRow = wsSrc.Cells(Rows.Count, "AA").End(xlUp).Row
```vba
Sub Update()
Dim wsSrc As Variant, srcList As Variant, wsDest As Worksheet, i As Integer, j As Integer, k As Integer, srcLastRow As Long, destLastRow As Long, srcFndVal As String, destFndCell As Range, srcValRow As Long, destValRow As Long, destFndVal As String, srcFndCell As Range
Application.ScreenUpdating = False
srcList = Array("Cust A", "Cust B", "Cust C", "Cust D", "Cust E", "Cust F", "Cust G")
Set wsDest = Worksheets("Master")
srcLastRow = wsSrc.Cells(Rows.Count, "AA").End(xlUp).Row
destLastRow = wsDest.Cells(Rows.Count, "A").End(xlUp).Row
j = wsDest.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).Row
For Each wsSrc In srcList
With wsDest
For i = 4 To srcLastRow
srcFndVal = wsSrc.Cells(i, "AA")
Set destFndCell = .Range("A:A").Find(srcFndVal, LookIn:=xlValues)
If destFndCell Is Nothing And wsSrc.Cells(i, "AA").Value <> "" Then
.Range("A" & j & ":F" & j).Value = wsSrc.Range("AA" & i & ":AF" & i).Value
.Range("J" & j & ":K" & j).Value = wsSrc.Range("AG" & i & ":AH" & i).Value
.Range("G" & j & ":H" & j).Value = wsSrc.Range("AE" & i & ":AF" & i).Value
j = j + 1
Else
srcValRow = wsSrc.Range("AA:AA").Find(what:=srcFndVal, after:=wsSrc.Range("AA4"), LookIn:=xlValues).Row
destValRow = wsDest.Range("A:A").Find(what:=srcFndVal, after:=wsDest.Range("A4"), LookIn:=xlValues).Row
.Range("B" & destValRow & ":F" & destValRow).Value = wsSrc.Range("AB" & srcValRow & ":AF" & srcValRow).Value
.Range("J" & destValRow & ":K" & destValRow).Value = wsSrc.Range("AG" & srcValRow & ":AH" & srcValRow).Value
End If
Next
For k = 4 To destLastRow
destFndVal = wsDest.Cells(k, "A")
Set srcFndCell = wsSrc.Range("AA:AA").Find(destFndVal, LookIn:=xlValues)
If srcFndCell Is Nothing And wsDest.Cells(k, "A").Value <> "" Then
.Range("B" & k & ":F" & k).Value = vbNullString
End If
Next
End With
Next wsSrc
Application.ScreenUpdating = True
End Sub
Try this
Sub Update()
Dim wsSrc As Worksheet
For Each wsSrc In ThisWorkbook.Worksheets
If wsSrc.Name <> "Master" Then
'Do bla bla...
End If
Next
End Sub
I have fix your code. Try this.
Your matter is wsSrc is a WorkSheet Object, but srcList is an array of String. They are not match each other.
I use a condition that wsSrc name start with "Cust" instead. Tell me if this solved your problem
Sub Update()
Dim wsSrc, wsDest As Worksheet
Dim i, j, k As Integer
Dim srcLastRow, destLastRow, srcValRow, destValRow As Long
Dim srcFndVal, destFndVal As String
Dim destFndCell, srcFndCell As Range
Application.ScreenUpdating = False
Set wsDest = Worksheets("Master")
For Each wsSrc In ThisWorkbook.Worksheets
If Left(wsSrc.Name, 4) = "Cust" Then
srcLastRow = wsSrc.Cells(Rows.Count, "BA").End(xlUp).Row
destLastRow = wsDest.Cells(Rows.Count, "A").End(xlUp).Row
j = wsDest.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).Row
With wsDest
For i = 4 To srcLastRow
srcFndVal = wsSrc.Cells(i, "AA")
Set destFndCell = .Range("A:A").Find(srcFndVal, LookIn:=xlValues)
If destFndCell Is Nothing And wsSrc.Cells(i, "AA").Value <> "" Then
.Range("A" & j & ":F" & j).Value = wsSrc.Range("AA" & i & ":AF" & i).Value
.Range("J" & j & ":K" & j).Value = wsSrc.Range("AG" & i & ":AH" & i).Value
.Range("G" & j & ":H" & j).Value = wsSrc.Range("AE" & i & ":AF" & i).Value
j = j + 1
Else
srcValRow = wsSrc.Range("AA:AA").Find(what:=srcFndVal, after:=wsSrc.Range("AA4"), LookIn:=xlValues).Row
destValRow = wsDest.Range("A:A").Find(what:=srcFndVal, after:=wsDest.Range("A4"), LookIn:=xlValues).Row
.Range("B" & destValRow & ":F" & destValRow).Value = wsSrc.Range("AB" & srcValRow & ":AF" & srcValRow).Value
.Range("J" & destValRow & ":K" & destValRow).Value = wsSrc.Range("AG" & srcValRow & ":AH" & srcValRow).Value
End If
Next
For k = 4 To destLastRow
destFndVal = wsDest.Cells(k, "A")
Set srcFndCell = wsSrc.Range("AA:AA").Find(destFndVal, LookIn:=xlValues)
If srcFndCell Is Nothing And wsDest.Cells(k, "A").Value <> "" Then .Range("B" & k & ":F" & k).Value = vbNullString
Next
End With
End If
Next
Application.ScreenUpdating = True
End Sub
Related
I have the following code:
Sub CreateDisableLists()
Dim LastRow As Long
Dim i As Long
LastRow = Cells(Rows.Count, "J").End(xlUp).Row
For i = 2 To LastRow
If _
Range("G" & i).Value = "DSDFDFFD" And Range("I" & i).Value = "Enabled" Or _
Range("G" & i).Value = "SFDDS" And Range("I" & i).Value = "Enabled" Or _
Range("G" & i).Value = "FFDFDSSF" And Range("I" & i).Value = "Enabled" Or _
Range("G" & i).Value = "FDFDSVSFD" And Range("I" & i).Value = "Enabled" Or _
Range("G" & i).Value = "FDFDSFD" And Range("I" & i).Value = "Enabled" Or _
Range("G" & i).Value = "GHFH" And Range("I" & i).Value = "Enabled" _
Then
Range("K" & i).Value = "TRUE"
Else
Range("K" & i).Value = "FALSE"
End If
Next i
End Sub
How can I compress the lines between "If" and "Then" so that I loop through a list of (DSDFDFFD, SFDDS, FFDFDSSF, etc") instead of what is written above? Using this code I need to add 68 lines between "If" and "Then".
You could start by setting K to be FALSE, then using If on column I, and Select Case on column G:
Sub sCreateDisableLists()
Dim LastRow As Long
Dim i As Long
LastRow = Cells(Rows.Count, "J").End(xlUp).Row
For i = 2 To LastRow
Range("K" & i).Value = "FALSE"
If Range("I" & i).Value = "Enabled" Then
Select Case Range("G" & i).Value
Case "xxx1", "xxx2", "xxx3", "xxx4", "xxx5", "xxx6"
Range("K" & i).Value = "TRUE"
End Select
End If
Next i
End Sub
If using multiple Or/And statements I highly recommend to use parenthesis to group them as you want them to validate, or you might not get the result you expect.
Your If statement could be like:
Dim Arr() As Variant
Arr = Array("DSDFDFFD", "SFDDS", "FFDFDSSF") 'define your keys here
If Range("I" & i).Value = "Enabled" And IsInArray(Range("I" & i).Value, Arr) Then
Range("K" & i).Value = "TRUE"
Else
Range("K" & i).Value = "FALSE"
End If
or even less:
Dim Arr() As Variant
Arr = Array("DSDFDFFD", "SFDDS", "FFDFDSSF") 'define your keys here
Range("K" & i).Value = UCase(Range("I" & i).Value = "Enabled" And IsInArray(Range("I" & i).Value, Arr))
using this function
Public Function IsInArray(ByVal stringToBeFound As String, ByVal Arr As Variant) As Boolean
IsInArray = (UBound(Filter(Arr, stringToBeFound)) > -1)
End Function
You could try:
Option Explicit
Sub CreateDisableLists()
Dim LastRow As Long, i As Long, y As Long
Dim strValues As String: strValues = "DSDFDFFD,SFDDS,FFDFDSSF,FDFDSVSFD,FDFDSFD,GHFH"
Dim strIvalue As String: strIvalue = "Enabled"
Dim arr As Variant
Dim BooleanStatus As Boolean
With ThisWorkbook.Worksheets("Sheet1")
LastRow = .Cells(.Rows.Count, "J").End(xlUp).Row
arr = Split(strValues, ",")
For i = 2 To LastRow
BooleanStatus = False
For y = LBound(arr) To UBound(arr)
If (.Range("G" & i).Value = arr(y)) And .Range("I" & i).Value = strIvalue Then
BooleanStatus = True
Exit For
End If
Next y
If BooleanStatus = True Then
.Range("K" & i).Value = "TRUE"
Else
.Range("K" & i).Value = "FALSE"
End If
Next i
End With
End Sub
Not very much to be improved, but the next code would be a little more compact:
Sub testImproveCode()
Dim LastRow As Long, i As Long
Dim j As Long, boolOk As Boolean
LastRow = Cells(Rows.count, "J").End(xlUp).Row
For i = 2 To LastRow
For j = 1 To 6
If Range("G" & i).value = "xxx" & j And _
Range("I" & i).value = "Enable" Then
boolOk = True: Exit For
Next j
If boolOk Then
Range("K" & i).value = "TRUE": boolOk = False
Else
Range("K" & i).value = "FALSE"
End If
Next i
End Sub
I am trying to vlookup few columns from another sheet, and I am trying to dynamically set range for the vlookup table and then copy and paste the formula down to my lookup values sheet (which works)
Any Help would be great!
I tried the code below but it does not set value in FRow or SRow.
Sub test()
Dim FRow As Long
Dim SRow As Long
With Sheets("M2URPN")
Set FRow = Sheets("M2URPN").Cells(Rows.Count, "A").End(xlUp).Row
End With
With Worksheets("M2URPN")
Set SRow = .sht.Cells(sht.Rows.Count, "G").End(xlUp).Row
End With
If Worksheets("RECONCILE").Range("A2") Is Nothing Then
Worksheets("RECONCILE").Range("A2").FormulaR1C1 = "NO RECORDS"
Else
With Worksheets("RECONCILE")
Range("B2").Formula = "=VLOOKUP(A2,M2URPN!$A$1:$E$" & FRow & ",4,FALSE)"
Range("B2:B" & Range("A" & Rows.Count).End(xlUp).Row).FillDown
Range("C2").Formula = "=VLOOKUP(A2,M2URPN!$A$1:$E$" & FRow & ",4,FALSE)"
Range("C2:C" & Range("A" & Rows.Count).End(xlUp).Row).FillDown
End With
End If
If Worksheets("RECONCILE").Range("E2") Is Nothing Then
Worksheets("RECONCILE").Range("E2").FormulaR1C1 = "NO RECORDS"
Else
With Worksheets("RECONCILE")
Range("F2").Formula = "=VLOOKUP(E2,M2URPN!$G$1:$J$" & SRow & ",4,FALSE)"
Range("F2:F" & Range("E" & Rows.Count).End(xlUp).Row).FillDown
Range("G2").Formula = "=VLOOKUP(E2,M2URPN!$G$1:$J$" & SRow & ",3,FALSE)"
Range("G2:G" & Range("E" & Rows.Count).End(xlUp).Row).FillDown
End With
End If
I fixed it as below:
Sub Vlookup()
Worksheets("RECONCILE").Activate
If Worksheets("RECONCILE").Range("A2") = "" Then
Worksheets("RECONCILE").Range("A2").FormulaR1C1 = "NO RECORDS"
Else
With Worksheets("RECONCILE")
Range("B2").Formula = "=VLOOKUP(A2,M2URPN!$A$1:$E$" & Sheets("M2URPN").Cells(Rows.Count, 1).End(xlUp).Row & ",4,FALSE)"
Range("B2:B" & Range("A" & Rows.Count).End(xlUp).Row).FillDown
Range("C2").Formula = "=VLOOKUP(A2,M2URPN!$A$1:$E$" & Sheets("M2URPN").Cells(Rows.Count, 1).End(xlUp).Row & ",4,FALSE)"
Range("C2:C" & Range("A" & Rows.Count).End(xlUp).Row).FillDown
Worksheets("RECONCILE").Range("B1").Value = "Amount"
Worksheets("RECONCILE").Range("C1").Value = "Customer Account"
End With
End If
If Worksheets("RECONCILE").Range("E2") = "" Then
Worksheets("RECONCILE").Range("E2").FormulaR1C1 = "NO RECORDS"
Else
With Worksheets("RECONCILE")
Range("F2").Formula = "=VLOOKUP(E2,M2URPN!$G$1:$J$" & Sheets("M2URPN").Cells(Rows.Count, 7).End(xlUp).Row & ",4,FALSE)"
Range("F2:F" & Range("E" & Rows.Count).End(xlUp).Row).FillDown
Range("G2").Formula = "=VLOOKUP(E2,M2URPN!$G$1:$J$" & Sheets("M2URPN").Cells(Rows.Count, 7).End(xlUp).Row & ",3,FALSE)"
Range("G2:G" & Range("E" & Rows.Count).End(xlUp).Row).FillDown
Worksheets("RECONCILE").Range("F1").Value = "Amount"
Worksheets("RECONCILE").Range("G1").Value = "Customer Account"
End With
End If
Worksheets("RECONCILE").Columns(2).NumberFormat = "0"
Worksheets("RECONCILE").Columns(7).NumberFormat = "0"
Range("A1:L1").Font.Bold = True
For Each sht In ThisWorkbook.Worksheets
sht.Cells.EntireColumn.AutoFit
Next sht
End Sub
New to VBA, I've pieced together the below code which makes changes to certain cells based upon activity in Column.
I split the actions into modules to make it easier to follow but now this only works when the change in column is copy/pasted (the macro does not work if I type into the column instead).
Any ideas what I'm missing?
The Sheet Code
Option Explicit
'Event Macro to put formulas in A, B and D if C changes
Private Sub Worksheet_Change(ByVal Target As Range) ' Every Change on this sheet do this code
Dim lRow As Long
Dim cell As Range
Dim CKeyCells As Range
' Set SelectionColumn range
Set CKeyCells = Range("$C$3:$C$1048576")
If Not Intersect(Target, Columns(3)) Is Nothing Then 'If the Change wasn't in Column
CbuddyMacro
End If
End Sub
The Module/Macro Code
Public Sub CbuddyMacro()
Dim lRow As Long
Dim cell As Range
Dim selectedRange As Range
Set selectedRange = Application.Selection
For Each cell In selectedRange
If cell.Value <> "" Then 'If Col has something in it then do the following.
lRow = cell.Row 'Get the current row
Cells(cell.Row, "A").Formula = "=IF(ISBLANK(I" & lRow & "),"""",I" & lRow & ")"
Cells(cell.Row, "B").Formula = "=IF(ISBLANK(J" & lRow & "),"""",J" & lRow & ")"
Cells(cell.Row, "D").Formula = "=IF(ISBLANK(K" & lRow & "),"""",K" & lRow & ")"
Cells(cell.Row, "E").Formula = "=IFERROR(INDEX(Database!$E$3:$E$1048576,MATCH(C" & lRow & ",Database!$C$3:Database!$C$1048576,0),0),"""")"
Cells(cell.Row, "F").Formula = "=IFERROR(IF(ISBLANK(INDEX(Database!$F$3:$F$1048576,MATCH(C" & lRow & ",Database!$C$3:Database!$C$1048576,0),0)),INDEX(Database!$P$3:$P$1048576,MATCH(C" & lRow & ",Database!$C$3:Database!$C$1048576,0),0),INDEX(Database!$F$3:$F$1048576,MATCH(C" & lRow & ",Database!$C$3:Database!$C$1048576,0),0)),"""")"
Cells(cell.Row, "G").Formula = "=IFERROR(IF(ISBLANK(INDEX(Database!$G$3:$G$1048576,MATCH(C" & lRow & ",Database!$C$3:Database!$C$1048576,0),0)),INDEX(Database!$Q$3:$Q$1048576,MATCH(C" & lRow & ",Database!$C$3:Database!$C$1048576,0),0),INDEX(Database!$G$3:$G$1048576,MATCH(C" & lRow & ",Database!$C$3:Database!$C$1048576,0),0)),"""")"
Cells(cell.Row, "H").Formula = "=IF(ISBLANK(L" & lRow & "),"""",L" & lRow & ")"
Cells(cell.Row, "I").Formula = "=IFERROR(TEXT(LOOKUP(2,1/($M$" & lRow & ":$AP$" & lRow & "<>""""),$M$" & lRow & ":$AP$" & lRow & "),""DD-MMM-YY""),"""")"
Cells(cell.Row, "J").Formula = "=IFERROR(TEXT(LOOKUP(2,1/($BU$" & lRow & ":$CX$" & lRow & "<>""""),$BU$" & lRow & ":$CX$" & lRow & "),""DD-MMM-YY""),"""")"
Cells(cell.Row, "K").Formula = "=IFERROR(LOOKUP(2,1/($AQ$" & lRow & ":$BT$" & lRow & "<>""""),$AQ$" & lRow & ":$BT$" & lRow & "),"""")"
Cells(cell.Row, "L").Formula = "=IFERROR(LOOKUP(2,1/($CY$" & lRow & ":$EB$" & lRow & "<>""""),$CY$" & lRow & ":$EB$" & lRow & "),"""")"
End If
If cell.Value = "" Then 'If Col has nothing in it then do the following.
Cells(cell.Row, "A").Formula = ""
Cells(cell.Row, "B").Formula = ""
Cells(cell.Row, "D").Formula = ""
Cells(cell.Row, "E").Formula = ""
Cells(cell.Row, "F").Formula = ""
Cells(cell.Row, "G").Formula = ""
Cells(cell.Row, "H").Formula = ""
Cells(cell.Row, "I").Formula = ""
Cells(cell.Row, "J").Formula = ""
Cells(cell.Row, "K").Formula = ""
Cells(cell.Row, "L").Formula = ""
End If
Next cell
This is a follow on from How do I get all the different unique combinations of 3 columns using VBA in Excel?
It almost what i need, however, my requirements is that it sums the third column which will contain figures instead of yes/no
Sub sample()
Dim ws As Worksheet
Dim lRow As Long, i As Long, j As Long
Dim col As New Collection
Dim Itm
Dim cField As String
Const deLim As String = "#"
Set ws = ThisWorkbook.Sheets("Sheet1")
With ws
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
For i = 2 To lRow
cField = .Range("A" & i).Value & deLim & _
.Range("B" & i).Value & deLim & _
.Range("C" & i).Value
On Error Resume Next
col.Add cField, CStr(cField)
On Error GoTo 0
Next i
i = 2
.Range("A1:C1").Copy .Range("F1")
.Range("I1").Value = "Count"
For Each Itm In col
.Range("F" & i).Value = Split(Itm, deLim)(0)
.Range("G" & i).Value = Split(Itm, deLim)(1)
.Range("H" & i).Value = Split(Itm, deLim)(2)
For j = 2 To lRow
cField = .Range("A" & j).Value & deLim & _
.Range("B" & j).Value & deLim & _
.Range("C" & j).Value
If Itm = cField Then nCount = nCount + 1
Next
.Range("I" & i).Value = nCount
i = i + 1
nCount = 0
Next Itm
End With
End Sub
This code was originally added by
Siddharth Rout
try this (follows comments)
Option Explicit
Sub Main()
Dim i As Long
Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")
For i = 4 To Range("A" & Rows.Count).End(xlUp).Row '<-- change 4 and "A" to your data actual upleftmost cell row and column
dict(cells(i, 1).Value & "|" & cells(i, 2).Value) = dict(cells(i, 1).Value & "|" & cells(i, 2).Value) + cells(i, 3).Value '<--| change 3 to your actual "column to sum up" index
Next
With Range("G3").Resize(dict.Count) '<-- change "G3" to your actual upleftmost cell to start writing output data from
.Value = Application.Transpose(dict.Keys)
.TextToColumns Destination:=.cells, DataType:=xlDelimited, Other:=True, OtherChar:="|"
.Offset(, 2).Resize(dict.Count).Value = Application.Transpose(dict.Items) '<--| change 2 to your actual column offset where to start writing summed values form
End With
End Sub
The codes below are edited by me to get the results but unlucky to get it. I am trying to compare sheet1 Col A&B with sheet2 Col A&B and result on sheet3. Kindly advise.
Sub ReconcileRegisters()
Dim i As Long, _
LRa As Long, _
LRb As Long, _
rowx As Long
LRa = Sheets("sheet1").Range("A1:B" & Rows.Count).End(xlUp).Row
LRb = Sheets("sheet2").Range("A1:B" & Rows.Count).End(xlUp).Row
rowx = 2
Application.ScreenUpdating = False
For i = 2 To LRa
If IsError(Application.Match(Sheets("sheet1").Range("A1:B" & i).Value, Sheets("sheet2").Range("A1:B" & LRb), 0)) Then
Sheets("sheet3").Range("A" & rowx).Value = Sheets("sheet1").Range("A1:B" & i).Value
rowx = rowx + 1
End If
Next i
For i = 2 To LRb
If IsError(Application.Match(Sheets("sheet2").Range("A1:B" & i).Value, Sheets("sheet1").Range("A1:B" & LRa), 0)) Then
Sheets("sheet3").Range("A" & rowx).Value = Range("A1:B" & i).Value
rowx = rowx + 1
End If
Next i
Application.ScreenUpdating = True
MsgBox "Matching process is complete"
End Sub
If you compare both loops then I would assume that you need Sheets("sheet2") in this second section:
Sheets("sheet3").Range("A" & rowx).Value = Range("A1:B" & i).Value