I am trying to compare to excel sheets with data 40000 rows and 35 columns.
There is common key in column A but data in both sheets are not same like.
in sheets 1 there may be
A
B
C
D
and in sheet2 there may be
A
C
D
E
So I want to compare both and provide the difference in summary sheet.
I have written code but don't know how to complete it.
Option Explicit
Sub Compare_Two_Excel_Files_Highlight_Differences()
'Define Object for Excel Workbooks to Compare
Dim sh As Integer, ShName As String, lColIdx As Long, sIdx As Long, ssh As String
Dim F1_Workbook As Workbook, F2_Workbook As Workbook, statmsg As String, trialcnt As Long
Dim iRow As Double, iCol As Double, iRow_Max As Double, iCol_Max As Double
Dim File1_Path As String, File2_Path As String, F1_Data As String, F2_Data As String, Header As String
'Assign the Workbook File Name along with its Path
File1_Path = ThisWorkbook.Sheets("Settings").Cells(2, 2)
File2_Path = ThisWorkbook.Sheets("Settings").Cells(3, 2)
iRow_Max = ThisWorkbook.Sheets("Settings").Cells(4, 2)
iCol_Max = ThisWorkbook.Sheets("Settings").Cells(5, 2)
lColIdx = ThisWorkbook.Sheets("Settings").Cells(6, 2).Interior.ColorIndex
'Open Files To Compare
Set F2_Workbook = Workbooks.Open(File2_Path)
Set F1_Workbook = Workbooks.Open(File1_Path)
' Windows("File1_Path.xlsx").Activate
' Columns("A:A").Select
' Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
' Range("A1").Select
' ActiveCell.FormulaR1C1 = "Key"
' Range("A2").Select
' Windows("File2_Path.xlsx").Activate
' Columns("A:A").Select
' Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
' Range("A1").Select
' ActiveCell.FormulaR1C1 = "Key"
' Range("A2").Select
'With F1_Workbook object, now it is possible to pull any data from it
'Read Data From Each Sheets of Both Excel Files & Compare Data
sIdx = 1
' trialcnt = 1
Header = 1
ThisWorkbook.Sheets("Summary").Cells.Clear
ThisWorkbook.Sheets("Summary").Cells(sIdx, 3) = F1_Workbook.Name
ThisWorkbook.Sheets("Summary").Cells(sIdx, 4) = F2_Workbook.Name
ThisWorkbook.Sheets("Summary").Activate
statmsg = Application.StatusBar
For sh = 1 To F1_Workbook.Sheets.Count
ShName = F1_Workbook.Sheets(sh).Name
ThisWorkbook.Sheets("Settings").Cells(7 + sh, 1) = ShName
ThisWorkbook.Sheets("Settings").Cells(7 + sh, 2) = "Identical Sheets"
ThisWorkbook.Sheets("Settings").Cells(7 + sh, 2).Interior.Color = vbWhite
Application.StatusBar = statmsg & " ,Processing Sheet: " & ssh
' If ThisWorkbook.Sheets("Settings").Cells(4, 2) = 0 Then iRow_Max = F1_Workbook.Sheets(ShName).Range("A:A").SpecialCells(xlLastCell).Row
' If ThisWorkbook.Sheets("Settings").Cells(5, 2) = 0 Then iCol_Max = F1_Workbook.Sheets(ShName).Range("A:A").SpecialCells(xlLastCell).Column
' For iRow = 1 To iRow_Max
' For iCol = 1 To iCol_Max
' F1_Data = F1_Workbook.Sheets(ShName).Cells(iRow, iCol)
' F2_Data = F2_Workbook.Sheets(ShName).Cells(iRow, iCol)
'Compare Data From Excel Sheets & Highlight the Mismatches
' Find row number
Dim Row As Long
Dim i As Integer
For i = 2 To ThisWorkbook.Sheets("Settings").Cells(4, 2).Value
On Error Resume Next
Row = Application.WorksheetFunction.Match(F1_Workbook.Sheets(ShName).Cells(i, 1).Value, F1_Workbook.Sheets(ShName).Range("A1:A200"), 0)
On Error GoTo 0
If lRow > 0 Then
'code
' If ThisWorkbook.Sheets("Settings").Cells(4, 2) = 0 Then iRow_Max = F1_Workbook.Sheets(ShName).Range("A:A").SpecialCells(xlLastCell).Row
' If ThisWorkbook.Sheets("Settings").Cells(5, 2) = 0 Then iCol_Max = F1_Workbook.Sheets(ShName).Range("A:A").SpecialCells(xlLastCell).Column
' For iRow = 1 To iRow_Max
' For iCol = 1 To iCol_Max
F1_Data = F1_Workbook.Sheets(ShName).Cells(i, iCol)
F2_Data = F2_Workbook.Sheets(ShName).Cells(Row, iCol)
If F1_Data <> F2_Data Then
' F1_Workbook.Sheets(ShName).Cells(iRow, iCol).Interior.ColorIndex = lColIdx
ThisWorkbook.Sheets("Settings").Cells(7 + sh, 2) = "Mismatch Found"
ThisWorkbook.Sheets("Settings").Cells(7 + sh, 2).Interior.ColorIndex = lColIdx
If ssh <> F1_Workbook.Sheets(sh).Name Then
sIdx = sIdx + 1
ThisWorkbook.Sheets("Summary").Cells(sIdx, 3) = F1_Workbook.Sheets(sh).Name
ThisWorkbook.Sheets("Summary").Cells(sIdx, 4) = F2_Workbook.Sheets(sh).Name
ThisWorkbook.Sheets("Summary").Cells(sIdx, 1) = F1_Workbook.Sheets(ShName).Cells(1, 1).Value
ThisWorkbook.Sheets("Summary").Cells(sIdx, 2) = "Field"
ssh = F1_Workbook.Sheets(sh).Name
End If
sIdx = sIdx + 1
' ThisWorkbook.Sheets("Summary").Cells(sIdx, 1) = F1_Workbook.Sheets(ShName).Cells(iRow, iCol).Address
ThisWorkbook.Sheets("Summary").Cells(sIdx, 2) = F1_Workbook.Sheets(ShName).Cells(Header, iCol).Value
ThisWorkbook.Sheets("Summary").Cells(sIdx, 1) = F1_Workbook.Sheets(ShName).Cells(iRow, 1).Value
ThisWorkbook.Sheets("Summary").Cells(sIdx, 3) = F1_Data
ThisWorkbook.Sheets("Summary").Cells(sIdx, 4) = F2_Data
ThisWorkbook.Sheets("Summary").Cells(sIdx, 2).Select
End If
' Next iCol
ThisWorkbook.Sheets("Settings").Cells(7 + sh, 2) = ThisWorkbook.Sheets("Settings").Cells(7 + sh, 2) & " (" & iRow_Max & "-Rows , " & iCol_Max & "-Cols Compared)"
' Next sh
Next i
End If
Trial_Exit:
'''''Process Completed
F2_Workbook.Close savechanges:=False
F1_Workbook.Close savechanges:=True
Set F2_Workbook = Nothing
Set F1_Workbook = Nothing
ThisWorkbook.Sheets("Settings").Activate
MsgBox "Task Completed"
Application.StatusBar = statmsg
' End With
' ThisWorkbook.Sheets("Settings").Cells(1, 4).Font.Color = vbRed
End Sub
Well, put this together just to show what you can do with match, the result is the position of the result in the list.
Edit: just to show how the formula changes when dealing with other sheets, ie data lists on sheets 1 and 2 with the match on sheet 3:
I know you are asking for code to do this, but if you are using Excel 2013 or later there is an add-on called Inquire that does this for you. If you go to File > Options > Add-Ins > COM Add-ins > check Inquire.
If you open both worksheets click on the Inquire ribbon and then select compare files. It will compare the two files and create a new workbook with the results.
There is also a lot of other cool functionality with this tool and you don't need to code anything.
This is the code you could try instead:
Sub wsCompare()
Dim ws1 As Worksheet, ws2 As Worksheet, wsResults As Worksheet
Dim strKey As String
Dim lngFindKey As Long
Dim rngFindKey As Range
Set ws1 = Sheets("Sheet1") 'set this to your first worksheet with data
Set ws2 = Sheets("Sheet2") 'set this to your second worksheet with data
Set wsResults = Sheets("Sheet3") 'set this to the worksheet with the results in it
For i = 1 To 4000 'update this to be the first row containing an ID to the last
strKey = ws1.Range("A" & i).Value
Set rngFindKey = ws2.Range("A:A").Find(WHAT:=strKey)
lngFindKey = rngFindKey.Row
For x = 1 To 35
If x = 1 Then
wsResults.Range("A" & i).Value = strKey
Else
'add code to calc your difference assuming all numerical values do something like this
wsResults.Range(Cells(i, x)).Value = ws2.Range(Cells(longFindKey, x)).Value - ws1.Range(Cells(i, x)).Value
End If
Next x
Next i
End Sub
Related
My problem is stated in the title. The error occurs in the first line with .Copy, but I have had it the same as the second one and received the same error.
I have checked so that the Sheet names are correct, and even copied them straight from the Sheet title in case some weird character sneaked in.
I'll put snippets of code here and then the full code in the end in case the problem is something different.
Declaration:
(I have tried setting it explicitly with Workbooks() but it didn't help)
Dim wb As Workbook
Set wb = ThisWorkbook' Or Workbooks("collected.xlsm")
Dim sUser As Worksheet, sExceptions As Worksheet
Set sUser = wb.Sheets("User")
Set sExceptions = wb.Sheets("Exceptions")
Copying:
sUser.Range(Cells(rS, 1)).Copy Destination:=sExceptions.Range(Cells(Count, 1))
sUser.Range(rS, 11).Copy Destination:=sExceptions.Range(Count, 2)
Entire code:
Option Explicit
Function FindExceptions()
' To run faster
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
' Variable def
Dim Count As Integer
' Variable def
' Worksheets
Dim wb As Workbook
Set wb = ThisWorkbook ' Or Workbooks("collected.xlsm")
Dim sUser As Worksheet, sVCD As Worksheet, sFullExport As Worksheet
Set sUser = wb.Sheets("User")
Set sVCD = wb.Sheets("VCD")
Set sFullExport = wb.Sheets("FullExport")
' r, f, c = Search, Find, Check
' For Each rows
Dim rS As Integer, rF As Integer, rC As Integer
'Set rS = sUser.Columns("A")
'Set rF = sVCD.Columns("A")
'Set rC = sFullExport("B")
' Vars used in execution
'Dim cS As Range, cF As Range, cC As Range
Dim secId As String, employeeNum As String, FoundVCD As Boolean, FoundFullExport As Boolean
' Go through User sheet
For rS = 2 To sUser.UsedRange.Rows.Count
secId = sUser.Cells(rS, "A").Value
employeeNum = sUser.Cells(rS, "K").Value
' Search for in VCD
FoundVCD = False
For rF = 2 To sVCD.UsedRange.Rows.Count
If sVCD.Cells(rF, "A").Value = secId And sVCD.Cells(rF, "K").Value = employeeNum Then
FoundVCD = True
Exit For
End If
Next
'Search for in Full Export?
If FoundVCD = True Then
FoundFullExport = False
For rC = 2 To sFullExport.UsedRange.Rows.Count
If sFullExport.Cells(rC, "B").Value = secId Then
FoundFullExport = True
Exit For
End If
Next
End If
If FoundFullExport = False Then
' WriteExceptions sUser.Cells(rS, "A").Value, sUser.Cells(rS, "K").Value, sFullExport.Cells(rC, "A").Value, sFullExport.Cells(rC, "D").Value
' Worksheet var
Dim sExceptions As Worksheet
Set sExceptions = wb.Sheets("Exceptions")
If Count = Null Or Count = 0 Then
sExceptions.Cells(1, "A") = "Säk. Id"
sExceptions.Cells(1, "B") = "Anst. Nr"
sExceptions.Cells(1, "C") = "Unison Id"
sExceptions.Cells(1, "D") = "Kort hex"
Count = 2
Else
Count = Count + 1
End If
' secId on col A, employeeNum on col B, unisonId on col C, cardHex on col D
sUser.Range(Cells(rS, 1)).Copy _
Destination:=sExceptions.Range(Cells(Count, 1))
sUser.Range(rS, 11).Copy _
Destination:=sExceptions.Range(Count, 2)
sFullExport.Range(rC, 1).Copy _
Destination:=sExceptions.Range(Count, 3)
sFullExport.Range(rC, 4).Copy _
Destination:=sExceptions.Range(Count, 4)
End If
Next
Count = 0
' To end settings to run faster
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Function
You're confusing Range and Cells.
Try
sUser.Cells(rs, 1).Copy _
Destination:=sExceptions.Cells(count, 1)
sUser.Cells(rs, 11).Copy _
Destination:=sExceptions.Cells(count, 2)
sFullExport.Cells(rC, 1).Copy _
Destination:=sExceptions.Cells(count, 3)
sFullExport.Cells(rC, 4).Copy _
Destination:=sExceptions.Cells(count, 4)
I am generating a new workbook from a multiple workbooks, i can generate a summary of all the errors found, but when i try to copy the sheets with the error information i got the runtime error 9
These is the line failing
If exists = True Then
ActiveWorkbook.Sheets(sheetName).Copy After:=ThisWorkbook.Sheets(1)
End If
Other thing i havent add is that all the sheets on the multiple files have the same names, so i want to know if there is a way that the sheet when is copy i can add the file name and the sheet name
Sub getViolations()
Path = "C:\Users\omartinr\Desktop\New folder (4)\New folder\"
Filename = Dir(Path & "*.xls")
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("Sheet1")
Set TxtRng = ws.Range("A1:N1")
TxtRng.Font.ColorIndex = 2
TxtRng.Interior.ColorIndex = 5
TxtRng.Value = [{"Partition Name","Tag","EM Supply","SH Signal","PK","Sfactor","FiSH","RESCAL","RESCAL","RESCAL","RESCAL","RESCAL","RESCAL","RESCAL"}]
TxtRng.HorizontalAlignment = xlCenter
Dim i As Integer
i = 2
Do While Filename <> ""
Workbooks.Open Filename:=Path & Filename, ReadOnly:=True
Dim wc As Worksheet
Set wc = ActiveWorkbook.Sheets("Violations Summary")
ws.Cells(i, 1).Value = ActiveWorkbook.Sheets("Violations Summary").Range("B1")
ws.Cells(i, 2).Value = ActiveWorkbook.Sheets("Violations Summary").Range("C1")
Dim count As Integer
count = 15
Dim sheetName As String, mySheetNameTest As String
Dim n As Integer
Dim exits As Boolean
For n = 3 To 14
If Not IsEmpty(wc.Cells(n, 2)) Then
If (wc.Cells(n, 2)) = 0 Then
ws.Cells(i, n).Font.ColorIndex = 4
ws.Cells(i, n).Value = wc.Cells(n, 2)
End If
If (wc.Cells(n, 2)) > 0 Then
Select Case wc.Cells(n, 1)
Case "PK"
sheetName = "Peak"
Case "Sfactor"
sheetName = "SF Supply"
Case Else
sheetName = wc.Cells(n, 1)
End Select
exists = sheetExists(sheetName)
If exists = True Then
ActiveWorkbook.Sheets(sheetName).Copy After:=ThisWorkbook.Sheets(1)
End If
ws.Cells(i, count) = wc.Cells(1, n).Value
ws.Cells(i, n).Font.ColorIndex = 3
ws.Cells(i, n).Value = wc.Cells(n, 2)
End If
If (ActiveWorkbook.Sheets("Violations Summary").Cells(n, 2)) < 0 Then
ws.Cells(i, n).Font.ColorIndex = 3
ws.Cells(i, n).Value = wc.Cells(n, 2)
End If
End If
If IsEmpty(wc.Cells(n, 2)) Then
ws.Cells(i, n).Value = ["NA"]
End If
count = count + 1
Next n
Workbooks(Filename).Close
Filename = Dir()
i = i + 1
Loop
End Sub
Function sheetExists(sheetToFind As String) As Boolean
sheetExists = False
For Each Sheet In Worksheets
If sheetToFind = Sheet.Name Then
sheetExists = True
Exit Function
End If
Next Sheet
End Function
Put option explicit at top so spelling of variables is checked and that they are declared. The variable exists was mispelt and there were a number of other variables not declared. I have put some other comments in with the code.
Some of the logic i think can be simplified and i have given some examples. Also, ensure consistent use of named variable wc. If nothing else it should be easier to debug now. Compiles on my machine so give it a try.
This all works on the assumption that each workbook you open has the "Violations Summary" sheet and it is spelt as shown.
You have the filename already stored in the variable Filename so you can use (concatenate?) that with the sheetname variable.
Option Explicit 'Set this to ensure all variable declared and consistent spelling
'Consider using WorkSheets collection rather than Sheets unless you have chart sheets as well?
Sub getViolations()
Dim Path As String 'Declare you other variables
Dim FileName As String
Path = "C:\Users\omartinr\Desktop\New folder (4)\New folder\"
FileName = Dir(Path & "*.xls")
Dim ws As Worksheet
Dim TxtRng As Range 'Declare this
Set ws = ThisWorkbook.Sheets("Sheet1")
Set TxtRng = ws.Range("A1:N1")
TxtRng.Font.ColorIndex = 2
TxtRng.Interior.ColorIndex = 5
TxtRng.Value = [{"Partition Name","Tag","EM Supply","SH Signal","PK","Sfactor","FiSH","RESCAL","RESCAL","RESCAL","RESCAL","RESCAL","RESCAL","RESCAL"}]
TxtRng.HorizontalAlignment = xlCenter
Dim i As Integer
i = 2
Do While FileName <> ""
Workbooks.Open FileName:=Path & FileName, ReadOnly:=True
Dim wc As Worksheet 'Consider whether to place these declarations just before the loop, avoids risk others may think there will be reinitialization even though there isn't
Set wc = ActiveWorkbook.Sheets("Violations Summary")
ws.Cells(i, 1).Value = wc.Range("B1") 'Use the wc variable
ws.Cells(i, 2).Value = wc.Range("C1")
Dim count As Integer
Dim sheetName As String, mySheetNameTest As String
Dim n As Integer
Dim exists As Boolean 'Corrected spelling
count = 15
For n = 3 To 14
If Not IsEmpty(wc.Cells(n, 2)) Then
If (wc.Cells(n, 2)) = 0 Then
ws.Cells(i, n).Font.ColorIndex = 4
ws.Cells(i, n).Value = wc.Cells(n, 2)
End If
If (wc.Cells(n, 2)) > 0 Then
Select Case wc.Cells(n, 1)
Case "PK"
sheetName = "Peak"
Case "Sfactor"
sheetName = "SF Supply"
Case Else
sheetName = wc.Cells(n, 1)
End Select
exists = sheetExists(sheetName)
If exists Then 'Shortened by removing = True (evaluates in same way)
ActiveWorkbook.Sheets(sheetName).Copy After:=ThisWorkbook.Sheets(1)
End If
ws.Cells(i, count) = wc.Cells(1, n).Value
ws.Cells(i, n).Font.ColorIndex = 3
ws.Cells(i, n).Value = wc.Cells(n, 2)
End If
If (wc.Cells(n, 2)) < 0 Then 'used wc variable
ws.Cells(i, n).Font.ColorIndex = 3
ws.Cells(i, n).Value = wc.Cells(n, 2)
End If
Else 'Simplified this as if is not empty then is empty so can use else
ws.Cells(i, n).Value = ["NA"] 'what is pupose of square brackets? These can be removed i think
End If
count = count + 1
Next n
Workbooks(FileName).Close
FileName = Dir()
i = i + 1
Loop
End Sub
Function sheetExists(sheetToFind As String) As Boolean
Dim Sheet As Worksheet ' declare
sheetExists = False
For Each Sheet In Worksheets
If sheetToFind = Sheet.Name Then
sheetExists = True
Exit Function
End If
Next Sheet
End Function
After you copy the ActiveWorkbook.Sheets(sheetName) to ThisWorkbook, ThisWorkbook becomes the ActiveWorkbook. ActiveWorkbook.Sheets(sheetName).Copy After:=ThisWorkbook.Sheets(1) should not throw an error but will probably cause ActiveWorkbook.Sheets("Violations Summary") to fail. For this reason, you should always fully qualify your references.
Some idealist programmers say that a subroutine should perform 1 simply task. Personally, I believe that if you have to scroll up, down, left or right to see what your code is doing it is time to refactor it. When refactoring I try to extract logical groups of tasks in a separate subroutine. This makes debugging and modifying the code far easier.
Refactored Code
Option Explicit
Sub getViolations()
Const Path As String = "C:\Users\omartinr\Desktop\New folder (4)\New folder\"
Dim n As Long
Dim Filename As String
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("Sheet1")
Sheet1Setup ws
Filename = Dir(Path & "*.xls")
Do While Filename <> ""
ProcessWorkbook Filename, ws.Rows(n)
Filename = Dir()
Loop
End Sub
Sub ProcessWorkbook(WBName As String, row As Range)
Dim nOffset As Long, n As Long
Dim sheetName As String
Dim WB As Workbook
Set WB = Workbooks.Open(Filename:=Path & Filename, ReadOnly:=True)
With WB.Sheets("Violations Summary")
row.Columns(1).Value = .Range("B1")
row.Columns(2).Value = .Range("C1")
nOffset = 12
For n = 3 To 14
If .Cells(n, 2) = "" Then
row.Columns(n).Value = ["NA"]
ElseIf (.Cells(n, 2)) = 0 Then
row.Columns(n).Font.ColorIndex = 4
row.Columns(n).Font.ColorIndex = 0
ElseIf (.Cells(n, 2)) = 0 Then
Select Case wc.Cells(n, 1)
Case "PK"
sheetName = "Peak"
Case "Sfactor"
sheetName = "SF Supply"
Case Else
sheetName = wc.Cells(n, 1)
End Select
'Range.Parent refers to the ranges worksheet. row.Parent refers to ThisWorkbook.Sheets(1)
If SheetExists(WB, sheetName) Then .Copy After:=row.Parent.Sheets(1)
row.Columns(n + nOffset) = .Cells(1, n).Value
row.Columns(n).Font.ColorIndex = 3
row.Columns(n).Value = .Cells(n, 2)
End If
Next
End With
WB.Close SaveChanges:=False
End Sub
Function SheetExists(WB As Workbook, sheetToFind As String) As Boolean
Dim ws As Worksheet
For Each ws In WB.Worksheets
If sheetToFind = ws.Name Then
SheetExists = True
Exit Function
End If
Next
End Function
Sub Sheet1Setup(ws As Worksheet)
With ws.Range("A1:N1")
.Value = [{"Partition Name","Tag","EM Supply","SH Signal","PK","Sfactor","FiSH","RESCAL","RESCAL","RESCAL","RESCAL","RESCAL","RESCAL","RESCAL"}]
.Font.ColorIndex = 2
.Interior.ColorIndex = 5
.HorizontalAlignment = xlCenter
End With
End Sub
Note: row is the target Row of ThisWorkbook.Sheets(1). row.Columns(3) is a fancy way to write row.Cells(1, 3) which refers to the 3rd cell in the target row. Also note that Cells, Columns, and Rows are all relative to the range they belong to. e.g. Range("C1").Columns(2) refers to D1, Range("C1").Rows(2).Columns(2) refers to D2, Range("C1").Cells(2,2) also refers to D2.
I am working on my computer to automate a quote in Excel with VBA
It consists of finding duplicates so they can be summed.
For example:
I have the following information:
Click here for the Excel file
The range from A2:C4 is a group that it states there are 28 bolts, 1 nut for each bolt & 1 washer for each bolt.
A5:C7 is another group that is the same 28 bolts, 1 nut for each bolt & 1 washer for each bolt.
A11:C13 is another group but the difference is that for this one are 2 nuts & 2 washer per bolt.
So this wont be sum
This would be the result:
I have the following code where it only looks through all the cells, I can't find a way to make it look in groups or ranges.
Sub Macro1()
Dim LastRow As Long, LastColumn As Long
Dim wSrc As Worksheet: Set wSrc = Sheets("Hoja1")
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
With wSrc
LastRow = .Range("B" & .Rows.Count).End(xlUp).Row
Set rng = .Range("B1:B" & LastRow)
LastColumn = .Cells(1, .Columns.Count).End(xlToLeft).Column + 2
rng.AdvancedFilter Action:=xlFilterCopy, copytoRange:=.Cells(1, LastColumn), unique:=True
Z = .Cells(.Rows.Count, LastColumn).End(xlUp).Row
LastColumn = LastColumn + 1
.Cells(1, LastColumn).Value = "Total"
.Range(.Cells(2, LastColumn), .Cells(Z, LastColumn)).Formula = _
"=SUMIF(" & rng.Address & "," & .Cells(2, LastColumn - 1).Address(False, False) & "," & rng.Offset(, 1).Address & ")"
End With
With Application
.ScreenUpdating = Truek
.Calculation = xlCalculationAutomatic
End With
End Sub
Click below for the Excel file
Here is an approach that utilizes User Defined Object for the Hardware, and Hardware groups.
We could create more compact code with fewer loops, but, unless there is a significant speed issue, this is probably more readable, and can be more easily adapted to future needs.
We create two class modules (and be sure to rename them as indicated in the code).
One class module is for the hardware items, the second is for the different groups.
The hardware items properties are the description, the weight per item, and the number of items.
The hardware groups properties are a collection of Hardware items, and the Quantity of items in that group.
We then combine the hardware groups into a collection of unique hardware groups.
As the code is written, you could combine in other ways to generate other types of reports.
The results:
Class Module 1
'**Rename: cHardware**
Option Explicit
Private pDescription As String
Private pWt As Double
Private pItemCount As Long
Public Property Get Description() As String
Description = pDescription
End Property
Public Property Let Description(Value As String)
pDescription = Value
End Property
Public Property Get Wt() As Double
Wt = pWt
End Property
Public Property Let Wt(Value As Double)
pWt = Value
End Property
Public Property Get ItemCount() As Long
ItemCount = pItemCount
End Property
Public Property Let ItemCount(Value As Long)
pItemCount = Value
End Property
Class Module 2
'**Rename: cHardwareGrp**
Option Explicit
Private pHW As cHardWare
Private pHWs As Collection
Private pQty As Long
Private Sub Class_Initialize()
Set pHWs = New Collection
End Sub
Public Property Get HW() As cHardWare
Set HW = pHW
End Property
Public Property Let HW(Value As cHardWare)
Set pHW = Value
End Property
Public Property Get HWs() As Collection
Set HWs = pHWs
End Property
Public Function AddHW(Value As cHardWare)
Dim I As Long, J As Long
If pHWs.Count = 0 Then
pHWs.Add Value
Else 'Insert in sorted order
For J = pHWs.Count To 1 Step -1
If pHWs(J).Description <= Value.Description Then Exit For
Next J
If J = 0 Then
pHWs.Add Value, before:=1
Else
pHWs.Add Value, after:=J
End If
End If
End Function
Public Property Get Qty() As Long
Qty = pQty
End Property
Public Property Let Qty(Value As Long)
pQty = Value
End Property
Regular Module
Option Explicit
Sub SummarizeHW()
Dim wsRes As Worksheet, wsSrc As Worksheet, rRes As Range
Dim vSrc As Variant, vRes() As Variant
Dim cHW As cHardWare, colHW As Collection
Dim cHWG As cHardwareGrp, colHWG As Collection
Dim colUniqueHWG As Collection
Dim I As Long, J As Long, K As Long
Dim lQTY As Long
Dim S As String
Dim V As Variant
Dim RE As Object, MC As Object
'Set Source and Results Worksheets and Ranges
Set wsSrc = Worksheets("Hoja1")
Set wsRes = Worksheets("Hoja2")
Set rRes = wsRes.Cells(1, 1)
'Get Source Data
With wsSrc
vSrc = .Range(.Cells(1, 2), .Cells(.Rows.Count, 2).End(xlUp)) _
.Offset(columnoffset:=-1).Resize(columnsize:=3)
End With
'Set up regex to extract number of HW items in description
Set RE = CreateObject("vbscript.regexp")
With RE
.Global = False
.Pattern = "^\((\d+)\)\s*"
.MultiLine = True
End With
'Collect unique list of hardware items
' compute the weight of each single item
Set colHW = New Collection
On Error Resume Next
For I = 2 To UBound(vSrc, 1) 'assumes header row
If vSrc(I, 1) <> "" Then lQTY = vSrc(I, 1)
Set cHW = New cHardWare
With cHW
S = vSrc(I, 2)
If RE.test(S) = True Then
Set MC = RE.Execute(S)
.ItemCount = CLng(MC(0).submatches(0))
Else
.ItemCount = 1
End If
.Wt = vSrc(I, 3) / lQTY / .ItemCount
.Description = S
colHW.Add cHW, .Description
End With
Next I
On Error GoTo 0
'Collect the Hardware Groups
'HW group starts if there is a "Qty" in column 1
Set colHWG = New Collection
For I = 2 To UBound(vSrc, 1)
If vSrc(I, 1) <> "" Then lQTY = vSrc(I, 1)
Set cHWG = New cHardwareGrp
Do
With cHWG
.HW = colHW(vSrc(I, 2))
.AddHW .HW
.Qty = lQTY
End With
I = I + 1
If I > UBound(vSrc, 1) Then Exit Do
Loop Until vSrc(I, 1) <> ""
colHWG.Add cHWG
I = I - 1
Next I
'Collect the unique hardware groups
' A group is defined by ALL of the hardware components being identical
' in both type and quantity. Therefore, we can concatenate them as a key
Set colUniqueHWG = New Collection
On Error Resume Next
For I = 1 To colHWG.Count
With colHWG(I)
ReDim V(1 To .HWs.Count)
For J = 1 To UBound(V)
V(J) = .HWs(J).Description
Next J
S = Join(V, "|")
colUniqueHWG.Add colHWG(I), S
Select Case Err.Number
Case 457 'a duplicate so add the QTY
colUniqueHWG(S).Qty = colUniqueHWG(S).Qty + .Qty
Err.Clear
Case Is <> 0 'error stop
Debug.Print Err.Number, Err.Description
End Select
End With
Next I
On Error GoTo 0
'Final Report
'# of columns = 3
'# of rows = sum of the number of HW items in each group + 1 for the header
J = 0
For I = 1 To colUniqueHWG.Count
J = J + colUniqueHWG(I).HWs.Count
Next I
ReDim vRes(0 To J, 1 To 3)
'Column headers
vRes(0, 1) = "Qty"
vRes(0, 2) = "Hardware Description"
vRes(0, 3) = "Weight"
'populate the results array'
K = 1
For I = 1 To colUniqueHWG.Count
With colUniqueHWG(I)
For J = 1 To .HWs.Count
If J = 1 Then vRes(K, 1) = .Qty
vRes(K, 2) = .HWs(J).Description
vRes(K, 3) = .Qty * .HWs(J).Wt * .HWs(J).ItemCount
K = K + 1
Next J
End With
Next I
'Write the results on a new sheet
Set rRes = rRes.Resize(UBound(vRes, 1) + 1, UBound(vRes, 2))
With rRes
.EntireColumn.Clear
.Value = vRes
.ColumnWidth = 255
With Rows(1)
.Font.Bold = True
.HorizontalAlignment = xlCenter
End With
.EntireColumn.AutoFit
End With
End Sub
Hmmm. I see from your comments that the hardware may not always be in the same order. I will add a sorting routine to our group generation so that will be irrelevant.
EDIT: The AddHW function was modified to insert the HW items in sorted order. Since there should only be a few items, this insertion sort should be adequate.
Taking a different approach.
take advantage of the structure; three lines define it
Put results on a different tab
This input ...
generates this output ...
using this code ...
Option Explicit
Sub Macro1()
Dim LastRow As Long, LastColumn As Long
Dim wSrc As Worksheet: Set wSrc = Sheets("Hoja1")
Dim tmpSrc As Worksheet
Dim outRng As Range, inRng As Range
Dim iLoop As Long, jLoop As Long, QSum As Long
' turn off updating for speed
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
' setup - tmpSrc is the working and final result
Set tmpSrc = ActiveWorkbook.Sheets.Add(, wSrc)
Set inRng = wSrc.UsedRange
inRng.Copy
tmpSrc.Range("A1").PasteSpecial (xlPasteAll)
With tmpSrc
.Name = "Hoja2"
Set outRng = .UsedRange
LastRow = .UsedRange.Rows.Count
LastColumn = .UsedRange.Columns.Count
End With
' loop down through the range
For iLoop = 2 To LastRow
If outRng.Cells(iLoop, 1) <> "" Then
QSum = outRng.Cells(iLoop, 1).Value
For jLoop = LastRow To iLoop + 1 Step -1 'loop up through the range to find a match
' matches are defined by all three rows in column B
If outRng.Cells(jLoop, 1) <> "" And _
outRng.Cells(iLoop, 2) = outRng.Cells(jLoop, 2) And _
outRng.Cells(iLoop + 1, 2) = outRng.Cells(jLoop + 1, 2) And _
outRng.Cells(iLoop + 2, 2) = outRng.Cells(jLoop + 2, 2) Then
QSum = QSum + outRng.Cells(jLoop, 1).Value
outRng.Rows(jLoop + 2).Delete
outRng.Rows(jLoop + 1).Delete
outRng.Rows(jLoop).Delete
LastRow = LastRow - 3
End If
Next jLoop
outRng.Cells(iLoop, 1).Value = QSum
End If
Next iLoop
For iLoop = 1 To 3
outRng.Columns(iLoop).ColumnWidth = inRng.Columns(iLoop).ColumnWidth
Next iLoop
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With
End Sub
Edit:
Summing weights for bolts, nuts, and washers
Checking for case where nuts and washers appear in reverse order
n.b. I am using .UsedRange to find the last row and last column. Other methods are available.
.
Option Explicit
Sub Macro1()
Dim LastRow As Long, LastColumn As Long
Dim wSrc As Worksheet: Set wSrc = Sheets("Hoja1")
Dim tmpSrc As Worksheet
Dim outRng As Range, inRng As Range
Dim iLoop As Long, jLoop As Long, QSum As Long
Dim WSum1 As Double, WSum2 As Double, WSum3 As Double
' turn off updating for speed
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
' setup - tmpSrc is the working and final result
Set tmpSrc = ActiveWorkbook.Sheets.Add(, wSrc)
Set inRng = wSrc.UsedRange
inRng.Copy
tmpSrc.Range("A1").PasteSpecial (xlPasteAll)
With tmpSrc
.Name = "Hoja2"
Set outRng = .UsedRange
LastRow = .UsedRange.Rows.Count
LastColumn = .UsedRange.Columns.Count
End With
' loop down through the range
For iLoop = 2 To LastRow
If outRng.Cells(iLoop, 1) <> "" Then
QSum = outRng.Cells(iLoop, 1).Value
WSum1 = outRng.Cells(iLoop, 3).Value
WSum2 = outRng.Cells(iLoop + 1, 3).Value
WSum3 = outRng.Cells(iLoop + 2, 3).Value
For jLoop = LastRow To iLoop + 1 Step -1 'loop up through the range to find a match
' matches are defined by all three rows in column B
If outRng.Cells(jLoop, 1) <> "" And _
outRng.Cells(iLoop, 2) = outRng.Cells(jLoop, 2) And _
outRng.Cells(iLoop + 1, 2) = outRng.Cells(jLoop + 1, 2) And _
outRng.Cells(iLoop + 2, 2) = outRng.Cells(jLoop + 2, 2) Then
QSum = QSum + outRng.Cells(jLoop, 1).Value
WSum1 = WSum1 + outRng.Cells(jLoop, 3).Value
WSum2 = WSum2 + outRng.Cells(jLoop + 1, 3).Value
WSum3 = WSum3 + outRng.Cells(jLoop + 2, 3).Value
outRng.Rows(jLoop + 2).Delete
outRng.Rows(jLoop + 1).Delete
outRng.Rows(jLoop).Delete
LastRow = LastRow - 3
Else ' check if bolts and washers are in reverse order
If outRng.Cells(jLoop, 1) <> "" And _
outRng.Cells(iLoop, 2) = outRng.Cells(jLoop, 2) And _
outRng.Cells(iLoop + 1, 2) = outRng.Cells(jLoop + 2, 2) And _
outRng.Cells(iLoop + 2, 2) = outRng.Cells(jLoop + 1, 2) Then
QSum = QSum + outRng.Cells(jLoop, 1).Value
WSum1 = WSum1 + outRng.Cells(jLoop, 3).Value
WSum2 = WSum2 + outRng.Cells(jLoop + 2, 3).Value
WSum3 = WSum3 + outRng.Cells(jLoop + 1, 3).Value
outRng.Rows(jLoop + 2).Delete
outRng.Rows(jLoop + 1).Delete
outRng.Rows(jLoop).Delete
LastRow = LastRow - 3
End If
End If
Next jLoop
outRng.Cells(iLoop, 1).Value = QSum
outRng.Cells(iLoop, 3).Value = WSum1
outRng.Cells(iLoop + 1, 3).Value = WSum2
outRng.Cells(iLoop + 2, 3).Value = WSum3
End If
Next iLoop
For iLoop = 1 To 3
outRng.Columns(iLoop).ColumnWidth = inRng.Columns(iLoop).ColumnWidth
Next iLoop
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With
End Sub
I have data in the format below in Sheet 1:
I want to reorganize the data in format below in Sheet 2:
The length for "Identifier" will be dynamic.
I have tried building macros for transpose with loops and copy range but havent been successful. Any help is greatly appreciated.
This works. But you would have to rearrange the final results' columns to move the "Identifier" column to the start of the result set.
Sub test()
Dim wb As Excel.Workbook
Dim ws As Excel.Worksheet
Dim A, B, R, C As Long
Dim x() As Variant
Dim y() As Variant
Set wb = ThisWorkbook
Set ws = wb.Sheets("Sheet1")
With ws
Range("A1").Select
A = Range("A" & Rows.Count).End(xlUp).Row
x = Range("A1", "I" & A)
y = Range("J1", "Z" & A)
For R = 1 To UBound(y, 1)
B = R + 0
For C = 1 To UBound(y, 2)
If (y(R, C)) <> "" Then
Range("A" & B, "H" & B).Copy
Range("A" & A + 1).PasteSpecial
Application.CutCopyMode = False
Range("I" & A + 1).Value = y(R, C)
A = A + 1
Else
GoTo xxx:
End If
Next C
xxx:
Next R
Range("A1").Select
End With
End Sub
If I understand what you are after, here is a macro that does that. When it starts it asks you to select the top left corner of the source data (it defaults to the active cell) and then it asks for the top left corner of the destination - while the selection box is up you can select the cell with the mouse if you don't want to type it in. Put this code in a Module:
Sub TransposeByLastColumn()
'get the top left corner of the source
Dim Source As Range
On Error Resume Next
Set Source = Application.InputBox("Select Source:", "Source", "=" & ActiveCell.Address, Type:=8)
On Error GoTo 0
If Source Is Nothing Then Set Source = ActiveCell
'get the top left corner of the destination
Dim Destination As Range
On Error Resume Next
Set Destination = Application.InputBox("Select Destination:", "Destination", Type:=8)
On Error GoTo 0
If Destination Is Nothing Then Exit Sub
'calculate the number of headers
Dim HeaderColumns As Long
HeaderColumns = 0
While Source.Offset(0, HeaderColumns).Value <> vbNullString
HeaderColumns = HeaderColumns + 1
Wend
'copy the headers
Dim HeaderIndex As Long
Destination.Offset(0, 0).Value = Source.Offset(0, HeaderColumns - 1).Value
For HeaderIndex = 1 To HeaderColumns - 1
Destination.Offset(0, HeaderIndex).Value = Source.Offset(0, HeaderIndex - 1).Value
Next
'copy the data
Dim SourceRowIndex As Long
Dim DestinationRowIndex As Long
Dim DataColumnIndex As Long
Dim IdentifierColumnIndex As Long
SourceRowIndex = 1
DestinationRowIndex = 1
While Source.Offset(SourceRowIndex, HeaderColumns - 1).Value <> vbNullString
IdentifierColumnIndex = 1
While Source.Offset(SourceRowIndex, HeaderColumns - 1 + IdentifierColumnIndex - 1).Value <> vbNullString
Destination.Offset(DestinationRowIndex, 0).Value = Source.Offset(SourceRowIndex, HeaderColumns - 1 + IdentifierColumnIndex - 1).Value
For DataColumnIndex = 1 To HeaderColumns - 1
Destination.Offset(DestinationRowIndex, DataColumnIndex).Value = Source.Offset(SourceRowIndex, DataColumnIndex - 1).Value
Next
IdentifierColumnIndex = IdentifierColumnIndex + 1
DestinationRowIndex = DestinationRowIndex + 1
Wend
SourceRowIndex = SourceRowIndex + 1
Wend
'show the result
Destination.Worksheet.Activate: Destination.Select
End Sub
The below is my code. I have tried many different solutions but none seem to work. Any help would be appreciated.
Sub MultiDimensiionArray1()
'array for sheet one and sheet two
Dim myArraySheet1(0 To 3, 0 To 4) As Variant
Dim myArraySheet2(0 To 5, 0 To 4) As Variant
Dim i As Long, j As Long ' dimension counter for for sheet one
Dim Dimension1 As Long, Dimension2 As Long ' dimension counter for for sheet one
'number of rows in sheet one
Dim x As Integer, NumRows As Integer
Sheet1.Activate
NumRows = Range("B2", Range("B2").End(xlDown)).Rows.Count
'store everything on sheet one in array
For i = LBound(myArraySheet1, 1) To UBound(myArraySheet1, 1)
For j = LBound(myArraySheet1, 2) To UBound(myArraySheet1, 2)
myArraySheet1(i, j) = Range("A2").Offset(i, j).Value
Next j
Next i
'store everything on sheet two in array
Sheet2.Activate
For Dimension1 = LBound(myArraySheet2, 1) To UBound(myArraySheet2, 1)
For Dimension2 = LBound(myArraySheet2, 2) To UBound(myArraySheet2, 2)
myArraySheet2(Dimension1, Dimension2) = Range("A2").Offset(Dimension1, Dimension2).Value
Next Dimension2
Next Dimension1
'READ FROM ARRAY/OR DISPLAY THE RESULT
Sheet1.Activate
' Select sheet one cell G2
Range("G2").Select
' Establish "For" loop to loop "numrows" number of times.
For x = 1 To NumRows
For i = LBound(myArraySheet1, 1) To UBound(myArraySheet1, 1)
For j = LBound(myArraySheet1, 2) To UBound(myArraySheet1, 2)
For Dimension1 = LBound(myArraySheet2, 1) To UBound(myArraySheet2, 1)
For Dimension2 = LBound(myArraySheet2, 2) To UBound(myArraySheet2, 2)
'if sheet one row equal to sheet two row execute the below code
If myArraySheet1(i, j) = myArraySheet2(Dimension1, Dimension2) Then
ActiveCell.Value = "YES IT IS DUPE AND NOT RESOLVED"
ActiveCell.Interior.ColorIndex = 4
ActiveCell.Font.ColorIndex = 2
ActiveCell.Offset(1, 0).Select
Else
ActiveCell.Value = "Brand New"
ActiveCell.Interior.ColorIndex = 3
ActiveCell.Font.ColorIndex = 2
End If
Next Dimension2
Next Dimension1
Next j
Next i
Next
End Sub
I did not use array but the code below give you the expected output that you want:
Option Explicit
Sub Compare()
Dim wb As Workbook
Dim ws1 As Worksheet, ws2 As Worksheet
Dim Lastrow As Long, Lastrow2 As Long
Dim i As Integer, j As Integer, c As Integer
Dim FOUND As Boolean
Set wb = ThisWorkbook
Set ws1 = wb.Sheets("Sheet1")
Set ws2 = wb.Sheets("Sheet2")
Lastrow = ws1.Range("A" & Rows.Count).End(xlUp).Row
Lastrow2 = ws2.Range("A" & Rows.Count).End(xlUp).Row
i = 2
Do
FOUND = False
For j = 2 To Lastrow2
For c = 1 To 5
If ws1.Cells(i, c).Value = ws2.Cells(j, c).Value Then
FOUND = True
Else
FOUND = False
Exit For
End If
Next c
If FOUND = True Then
ws1.Cells(i, 7) = "YES IT IS DUPE AND NOT RESOLVED"
Exit For
End If
Next j
If FOUND = False Then
ws1.Cells(i, 7) = "Brand new"
End If
i = i + 1
Loop While i < Lastrow + 1
End Sub
With this you'll have two arrays containing values of cells that aren't equal so you'll be able to use the values you need to do what you want
Sub Test()
Dim DiffSh1() As Variant
Dim DiffSh2() As Variant
Call Compare_Sheets(ThisWorkbook.Sheets("Sheet1"), ThisWorkbook.Sheets("Sheet2"), DiffSh1, DiffSh2)
'Now you can use the values in the two arrays as you need
For x = LBound(DiffSh1, 1) To UBound(DiffSh1, 1)
For y = LBound(DiffSh1, 2) To UBound(DiffSh1, 2)
If DiffSh1(x, y) <> "" Then
MsgBox ("Cell at Row " & x & " Column " & y & " isn't equal:" & vbCrLf & _
"Value in sheet1 is: " & DiffSh1(x, y) & vbCrLf & _
"Value in sheet2 is: " & DiffSh2(x, y))
End If
Next y
Next x
End Sub
Public Sub Compare_Sheets(ByVal Sh1 As Worksheet, ByVal Sh2 As Worksheet, ByRef DiffIn1() As Variant, ByRef DiffIn2() As Variant)
Dim LastCol
Dim LastRow
LastCol = Sh1.Cells(1, 1).SpecialCells(xlLastCell).Column
If Sh2.Cells(1, 1).SpecialCells(xlLastCell).Column > LastCol Then
LastCol = Sh2.Cells(1, 1).SpecialCells(xlLastCell).Column
End If
LastRow = Sh1.Cells(1, 1).SpecialCells(xlLastCell).Row
If Sh2.Cells(1, 1).SpecialCells(xlLastCell).Row > LastRow Then
LastRow = Sh2.Cells(1, 1).SpecialCells(xlLastCell).Row
End If
ReDim DiffIn1(1 To LastRow, 1 To LastCol)
ReDim DiffIn2(1 To LastRow, 1 To LastCol)
Dim mCol As Long, mRow As Long
For mCol = 1 To LastCol
For mRow = 1 To LastRow
If Sh1.Cells(mRow, mCol) <> Sh2.Cells(mRow, mCol) Then
DiffIn1(mRow, mCol) = Sh1.Cells(mRow, mCol).Value
DiffIn2(mRow, mCol) = Sh2.Cells(mRow, mCol).Value
Else
DiffIn1(mRow, mCol) = ""
DiffIn2(mRow, mCol) = ""
End If
Next mRow
Next mCol
End Sub