Close and Re-open workbook followed by SaveAs .prn - vba

I have been busy with creating a code for sorting a database in a new workbook.
Sheet2 of this workbook needs to be saved next to the workbook as "Sheet2.prn". I managed to do this, but today I needed to add 2 columns to Sheet2 and now for some reason the last step of resaving the file as .prn doesn't work anymore. I really don't have a clue what I have done wrong as I'm pretty sure I didn't change anything to the last part of my code.
This is my code:
Option Explicit
Sub RowCount()
Dim Oldstatusbar As Boolean
Dim DOF As Integer, Counter As Integer
Dim CurrentMin As Long, StartRow As Long, StartColumn As Long
Dim OutputColumn As Long, OutputRow As Long, InputValue As Long
Dim Borehole As String, Start_Row As String, End_Row As String, Output As String, FolderPath As String
Dim CurrentName As String
Dim rng As RANGE, Cell As RANGE, brh As RANGE, Undef1 As RANGE, Undef2 As RANGE
Dim r1 As RANGE, r2 As RANGE, r3 As RANGE, r4 As RANGE, r5 As RANGE, r6 As RANGE, r7 As RANGE, r8 As RANGE, r9 As RANGE
Dim r10 As RANGE, r11 As RANGE, r12 As RANGE, r13 As RANGE
Dim wbMain As Workbook, wbWellsRowCount As Workbook
Dim wsLog As Worksheet, wsSheet1 As Worksheet, wsSheet2 As Worksheet
Dim HCdatabase2 As Variant
Oldstatusbar = Application.DisplayStatusBar
Set wbMain = Workbooks("HCdatabase2.xlsm")
Set wsLog = wbMain.Sheets("Log")
FolderPath = ThisWorkbook.Path
DOF = 1
Counter = 1
wsLog.Select
StartColumn = 1
StartRow = 1
wsLog.Cells(StartRow + DOF, StartColumn).End(xlDown).Select
Set rng = wsLog.RANGE(wsLog.Cells(StartRow + DOF, StartColumn), wsLog.Cells(StartRow + DOF, StartColumn).End(xlDown))
CurrentName = wsLog.Cells(StartRow + DOF, StartColumn).Value
CurrentMin = Cells(StartRow + DOF, StartColumn).Row
Set wbWellsRowCount = Workbooks.Add
wbWellsRowCount.SaveAs FolderPath & "\wbWellsRowCount.xls"
Set wsSheet1 = wbWellsRowCount.Sheets("Sheet1")
wsSheet1.Select
OutputColumn = 1
OutputRow = DOF + 1
wsSheet1.Cells(OutputRow, OutputColumn).Value = CurrentName
wsSheet1.Cells(OutputRow, OutputColumn + 1).Value = CurrentMin
wsSheet1.Cells(1, 1).Name = "Borehole"
wsSheet1.Cells(1, 2).Name = "Start_Row"
wsSheet1.Cells(1, 3).Name = "End_Row"
wsSheet1.Cells(1, 4).Name = "Output"
ActiveWorkbook.Sheets.Add After:=Worksheets(Worksheets.Count)
Set wsSheet2 = wbWellsRowCount.Sheets("Sheet2")
Set r1 = Workbooks("HCdatabase2.xlsm").Worksheets("Log").RANGE("A:A")
Set r2 = Workbooks("wbWellsRowCount.xls").Worksheets("Sheet2").RANGE("A:A")
Set r3 = Workbooks("HCdatabase2.xlsm").Worksheets("Log").RANGE("J:J")
Set r4 = Workbooks("wbWellsRowCount.xls").Worksheets("Sheet2").RANGE("B:B")
Set r5 = Workbooks("HCdatabase2.xlsm").Worksheets("Log").RANGE("M:M")
Set r6 = Workbooks("wbWellsRowCount.xls").Worksheets("Sheet2").RANGE("C:C")
Set r7 = Workbooks("HCdatabase2.xlsm").Worksheets("Log").RANGE("AC:AC")
Set r8 = Workbooks("wbWellsRowCount.xls").Worksheets("Sheet2").RANGE("D:D")
Set r9 = Workbooks("HCdatabase2.xlsm").Worksheets("Log").RANGE("AF:AF")
Set r10 = Workbooks("wbWellsRowCount.xls").Worksheets("Sheet2").RANGE("E:E")
Set r11 = Workbooks("HCdatabase2.xlsm").Worksheets("Log").RANGE("D:D")
Set r12 = Workbooks("wbWellsRowCount.xls").Worksheets("Sheet2").RANGE("F:F")
Set r13 = Workbooks("wbWellsRowCount.xls").Worksheets("Sheet2").RANGE("G:G")
r1.Copy r2
r3.Copy r4
r5.Copy
r6.PasteSpecial Paste:=xlPasteValues
r7.Copy r8
r9.Copy
r10.PasteSpecial Paste:=xlPasteValues
r11.Copy r12
r11.Copy r13
Application.CutCopyMode = False
With wbWellsRowCount.Sheets("Sheet2")
With .RANGE("A2", .Cells(.Rows.Count, 1).End(xlUp))
.Offset(.Rows.Count).Value = .Value
.Offset(.Rows.Count, 1).Value = .Offset(, 3).Value
.Offset(.Rows.Count, 4).Value = .Offset(, 4).Value
.Offset(.Rows.Count, 5).Value = .Offset(, 5).Value
.Offset(.Rows.Count, 6).Value = .Offset(, 6).Value
.Offset(, 4).ClearContents
.Offset(, 3).EntireColumn.Delete
With .Offset(, 1).Resize(2 * .Rows.Count)
If WorksheetFunction.CountBlank(.Cells) > 0 Then .SpecialCells(XlCellType.xlCellTypeBlanks).EntireRow.Delete
End With
End With
With .RANGE("A2", .Cells(.Rows.Count, 1).End(xlUp)).Resize(, 7)
.Sort key1:=.Cells(1, 1), order1:=xlAscending, key2:=.Cells(1, 2), order2:=xlAscending, Header:=xlNo, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2:=xlSortNormal
End With
End With
Set Undef1 = Workbooks("wbWellsRowCount.xls").Worksheets("Sheet2").UsedRange
On Error Resume Next
InputValue = -999
For Each Cell In Undef1
If IsEmpty(Cell) Then
Cell.Value = InputValue
End If
Next
On Error Resume Next
For Each Cell In r12
If (Cell) Then
Cell.Value = Left(Cell.Value, 2)
End If
Next
Columns("A:F").HorizontalAlignment = xlRight
Columns("A:F").AutoFit
Columns("E").ColumnWidth = 9
For Each Cell In rng
If Cell.Value <> CurrentName Then
wsSheet1.Cells(OutputRow, OutputColumn + 2).Value = Cell.Row - 1
CurrentName = Cell.Value
CurrentMin = Cell.Row
OutputRow = OutputRow + 1
wsSheet1.Cells(OutputRow, OutputColumn).Value = CurrentName
wsSheet1.Cells(OutputRow, OutputColumn + 1).Value = CurrentMin
wsSheet1.Cells(Counter + DOF, "D").Value = Counter
Counter = Counter + 1
End If
Next Cell
Set Cell = rng.End(xlDown)
wsSheet1.Cells(OutputRow, OutputColumn + 2).Value = Cell.Row
wsSheet1.Cells(Counter + DOF, "D").Value = Counter
wbWellsRowCount.Close True
wbWellsRowCount.Open
'wbWellsRowCount.Open FolderPath & "\wbWellsRowCount.xls"
wbWellsRowCount.Worksheets("Sheet2").SaveAs Filename:="HCShowDatabase.prn", FileFormat:=xlTextPrinter
Workbooks("HCShowDatabase.prn").Close True
wbMain.Activate
RANGE("A1").Select
ActiveWindow.ScrollRow = RANGE("A1").Row
Application.ScreenUpdating = True
Application.DisplayStatusBar = Oldstatusbar
End Sub
I tried both 2nd (worked fine before) and 3rd rule, but for some reason the file doesn't re-open.
To be specific, I want the workbook "wbWellsRowCount" to be saved and then re-opened so that I can SaveAs as Space delimited text file.
Can anyone help me with this?

Because the workbook is already open. It doesn't make any sense to close it and re-open it, doing so is expensive/time-consuming and serves no real purpose that I can see.
Also, you can't do it this way, because once you do the .Close True, the object is no longer available for you to use the .Open method, and were it not for your On Error Resume Next, this line would definitely raise an error (91: Object Variable Or With Block Not Set).
Get rid of:
wbWellsRowCount.Close True '### DELETE THIS LINE
wbWellsRowCount.Open '### DELETE THIS LINE
So that you're left with just this:
wbWellsRowCount.Worksheets("Sheet2").SaveAs Filename:="HCShowDatabase.prn", FileFormat:=xlTextPrinter
Workbooks("HCShowDatabase.prn").Close True

Related

VBA Excel match Copy Paste If Else

If Cell.value from Sheet2.Column"A" has no match in Sheet("Civil").Column"A" than copy that cell into Sheets("Sheet2).Column "D"
Correct Results
Correct result should look like on the attached picture but I have problem with
writing a correct code to fill Sheets("Sheet2).Column "D"
Sub NewSearch_A()
Dim cell As Range, rng As Range, rng2 As Range, rng3 As Range, cell1 As Range, n As Integer, m As Integer
Set rng = Sheets("Civil").Range("A2:A1000")
Set rng2 = Sheets("Sheet2").Range("A1:A100")
Set rng3 = Sheets("Sheet2").Range("C1:C100")
Set rng4 = Sheets("Sheet2").Range("D1:D100")
n = 1
m = 1
For Each cell In rng
n = n + 1
For Each cell1 In rng2
m = m + 1
If cell.Value = cell1.Value Then
Sheets("Sheet2").Range("C" & m & ":C" & m).Value = Sheets("Civil").Range("B" & n & ":B" & n).Value
Else
' ????????????????????????????????????????????????
End If
Next cell1
m = 1
Next cell
ActiveSheet.Columns("A:C").AutoFit
End Sub
Avoid the second loop with a WorksheetFunction MATCH function.
Sub NewSearch_A()
Dim rw As Long, mtch As Variant, wsc As Worksheet
Set wsc = Worksheets("Civil")
With Worksheets("Sheet2")
For rw = 2 To .Cells(.Rows.Count, "A").End(xlUp).Row
mtch = Application.Match(.Cells(rw, "A").Value2, wsc.Columns("A"), 0)
If IsError(mtch) Then
.Cells(rw, "D") = .Cells(rw, "A").Value2
Else
.Cells(rw, "C") = wsc.Cells(mtch, "B").Value2
End If
Next rw
End With
End Sub

speed up the processing of excel vba

I've created excel vba file. However, it takes very long time to run the whole file because the total of the rows is up to 270,000 lines. Does anyone know how can I speed up the running process? Any help would be much appreciated. Thanks in advance.
Sub datemodifiedFile()
Dim File1 As Object
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set File1 = fso.getfile("C:\Users\Meg\Desktop\Master File.xlsx")
If Sheets("today").Range("B1").Value = File1.DateLastModified Then
Else
Sheets("today").Range("B1").Value = File1.DateLastModified
Dim WbB As Workbook
Set WbB = Workbooks.Open(Filename:="C:\Users\Meg\Desktop\Master File.xlsx", ReadOnly:=True)
Dim SheetB As Worksheet
Dim lastrow As Long
Set SheetB = WbB.Sheets("Sheet1")
SheetB.Select
Rows("1:1").Select
'Selection.AutoFilter
'ActiveSheet.Range("A:V").AutoFilter Field:=20, Criteria1:=""
Columns("A:V").Select
Selection.Copy
ThisWorkbook.Activate
Sheets("today").Select
Range("C1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'Columns("A:X").Select
'ActiveSheet.Range("$A$1:$X$750001").RemoveDuplicates Columns:=Array(3, 4, 6), _
Header:=xlYes
Application.CutCopyMode = False
lastrow = Sheets("today").Range("D" & Rows.Count).End(xlUp).Row
Sheets("today").Cells(lastrow, 3).EntireRow.Delete
WbB.Close False
End If
End Sub
Sub dltnew()
Dim i As Long
Dim lrow As Long
lrow = Sheets("today").Range("C" & Rows.Count).End(xlUp).Row
For i = 2 To lrow
If Sheets("today").Cells(i, 2).Value = "NEW" Then
Sheets("today").Cells(i, 2).Value = ""
Sheets("today").Cells(i, 1).Value = ""
End If
Next i
End Sub
Sub comdate()
Dim Sheet1 As Worksheet
Dim Sheet3 As Worksheet
Dim lrow As Long
Dim i As Long
Set Sheet1 = ThisWorkbook.Sheets("main")
Set Sheet3 = ThisWorkbook.Sheets("today")
Sheet3.Range("A1").Value = Date
Sheet3.Range("A1").NumberFormat = "dd/mm/yyyy"
Sheet3.Range("A1").Font.Color = Sheet3.Range("A1").Interior.Color
Sheet3.Columns("A:A").EntireColumn.Hidden = False
If Sheet1.Range("B1").Value <> Sheet3.Range("A1").Value Then
Sheet1.Range("B1").Value = Sheet3.Range("A1").Value
lrow = Sheet1.Range("C" & Rows.Count).End(xlUp).Row
For i = 2 To lrow
If Sheet1.Cells(i, 2).Value = "NEW" Then
Sheet1.Cells(i, 2).Value = ""
End If
Next i
End If
End Sub
Sub Con()
Dim LasRow As Long
Application.ScreenUpdating = False
LasRow = Sheets("today").Range("C" & Rows.Count).End(xlUp).Row
Sheets("today").Range("A2:A" & LasRow).Formula = "=C2&G2&I2"
ActiveSheet.AutoFilterMode = False
Application.ScreenUpdating = True
End Sub
Sub Compare()
Dim mrow As Range, trow As Long
With Worksheets("main")
Set mrow = .Range("A2", .Range("A" & Rows.Count).End(xlUp))
End With
trow = Worksheets("today").Range("A" & Rows.Count).End(xlUp).Row
With Worksheets("today")
For j = 2 To trow
If mrow.Find(What:=.Range("A" & j).Value, LookIn:=xlValues, LookAt:=xlWhole) Is Nothing _
Then .Range("B" & j).Value = "NEW"
Next j
End With
End Sub
Sub getnew()
Dim Sheet1 As Worksheet
Dim Sheet3 As Worksheet
Dim lastrow As Long
Dim i As Long
Dim erow As Long
Set Sheet1 = ThisWorkbook.Sheets("main")
Set Sheet3 = ThisWorkbook.Sheets("today")
lastrow = Sheet3.Range("C" & Rows.Count).End(xlUp).Row
For i = 2 To lastrow
If Sheet3.Cells(i, 2).Value = "NEW" Then
erow = Sheet1.Range("C" & Rows.Count).End(xlUp).Row + 1
Sheet3.Cells(i, 2).EntireRow.Copy Destination:=Sheet1.Range("A" & erow)
Application.CutCopyMode = False
Sheet1.Select
Range("A1:X750001").Select
Selection.Sort Key1:=Range("G2"), Order1:=xlAscending, Key2:=Range("C2") _
, Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:= _
False, Orientation:=xlTopToBottom
End If
Next i
End Sub
Sub hidecellvalue()
Dim Sheet1 As Worksheet
Dim lastrow As Long
Dim k As Long
Set Sheet1 = ThisWorkbook.Sheets("main")
lastrow = Sheet1.Range("B" & Rows.Count).End(xlUp).Row
For k = 2 To lastrow
If Sheet1.Cells(k, 1).Value <> "NEW" Then
Sheet1.Cells(k, 1).Font.Color = Sheet1.Cells(k, 1).Interior.Color
'Sheet1.Columns("A:A").EntireColumn.Hidden = False
End If
Next k
End Sub
Sub hideSh1column()
Dim Sheet1 As Worksheet
Set Sheet1 = ThisWorkbook.Sheets("main")
Sheet1.Columns("A:A").EntireColumn.Hidden = True
Sheet1.Columns("D:F").EntireColumn.Hidden = True
Sheet1.Columns("H:H").EntireColumn.Hidden = True
Sheet1.Columns("L:L").EntireColumn.Hidden = True
Sheet1.Columns("N:N").EntireColumn.Hidden = True
Sheet1.Columns("P:P").EntireColumn.Hidden = True
End Sub
Sub HideSheet3()
Sheets("today").Visible = xlSheetVisible
End Sub
I would start with remove as much as .activate and select you have in your code and replace it with proper sheet.cell/range selection.
Then i would add this on beggining of your code
Dim previousScreenUpdating As Boolean
previousScreenUpdating = Application.ScreenUpdating
Application.ScreenUpdating = False
Dim previousCalculation As XlCalculation
previousCalculation = Application.Calculation
Application.Calculation = xlCalculationManual
and this on the end of your code
Application.ScreenUpdating = previousScreenUpdating
Application.Calculation = previousCalculation
This should be much faster.
You should always try to do as much using arrays as possible, rather than going through your data cell-by-cell.
In addition, a dictionary-based lookup is always going to beat using Find() when you're checking things in a large loop.
Sub Compare()
Dim mrow As Range, trow As Long, arr, r As Long
Dim d As Object, rngV As Range
Dim arrV, arrN, wsT As Worksheet, wsM As Worksheet
Set d = CreateObject("Scripting.Dictionary")
Set wsM = Worksheets("Main")
Set wsT = Worksheets("today")
'get all unique values in ColA on Main
arr = wsM.Range(wsM.Range("A2"), wsM.Cells(wsM.Rows.Count, 1).End(xlUp)).Value
For r = 1 To UBound(arr, 1)
d(arr(r, 1)) = 1
Next r
Set rngV = wsT.Range(wsT.Range("A2"), wsT.Cells(wsT.Rows.Count, 1).End(xlUp))
arrV = rngV.Value 'values from colA as array
arrN = rngV.Offset(0, 1).Value 'values from colB as array
'check colA against the dictionary and update colB array as needed
For r = 1 To UBound(arrV, 1)
If Not d.exists(arrV(r, 1)) Then arrN(r, 1) = "NEW"
Next r
'repopulate ColB with updated data
rngV.Offset(0, 1).Value = arrN
End Sub

VBA - Compare Cell Values In Multiple Work Sheets

I've tasked myself with building a small QA tool, but the problem is that I'm not terribly familiar with VBA or programming. I want to be able to iterate through a single column within three different .csv files. The cells in these columns should match, and the whole point of the tool is to identify the cells that are the "odd man out".
Currently I have some spaghetti code that's giving me an error "false.xlsx" not found...please be gentle...
Sub CompareLists()
Dim count As Integer
Dim kRange As Range
Dim LastRow As Long
Dim iRow As Long
Dim varSheetA As Variant
Dim varSheetB As Variant
Dim varSheetC As Variant
LastRow = Range("A" & Rows.count).End(xlUp).Row
Set kRange = ActiveSheet.Range("A3:A" & LastRow)
Set File_Path1 = Workbooks.Open(Filename = "C:\Test Files\Test_File1.csv")
Set varSheetA = File_Path1.Worksheets("Sheet1").Range(kRange)
Set File_Path2 = Workbooks.Open(Filename = "C:\Test Files\Test_File2.csv")
Set varSheetB = File_Path2.Worksheets("Sheet1").Range(kRange)
Set File_Path3 = Workbooks.Open(Filename = "C:\Test Files\Test_File3.csv")
Set varSheetC = File_Path3.Worksheets("Sheet1").Range(kRange)
For iRow = LBound(varSheetA) To UBound(varSheetA)
count = 1
If varSheetA(iRow) = varSheetB(iRow) Then
count = count + 1
Else
If varSheetA(iRow) = varSheetC(iRow) Then
count = count + 1
Else
If count < 3 Then
ActiveCell.Interior.ColorIndex = 3
End If
End If
End If
Next
End Sub
Your line:
Set File_Path1 = Workbooks.Open(Filename = "C:\Test Files\Test_File1.csv")
Evaluates the inside as a boolean check of whether some nonexistent Filename variable has the value "C:\Test Files\Test_File1.csv". Since the new variable Filename has no value, the comparison returns false. You were probably trying to do := and not =. The := operator assigns to a method parameter while = either does a boolean evaluation or variable assignment. Any one of the following four lines should fix your error as the first use the := operator to assign to the Filename parameter and the last two just know that Filename is the default first parameter.
Set File_Path1 = Workbooks.Open(Filename:="C:\Test Files\Test_File1.csv")
Set File_Path1 = Workbooks.Open Filename:="C:\Test Files\Test_File1.csv"
Set File_Path1 = Workbooks.Open("C:\Test Files\Test_File1.csv")
Set File_Path1 = Workbooks.Open "C:\Test Files\Test_File1.csv"
As a side note, this is something to be very careful about in VBA. Put Option Explicit at the top of every module so that it forces you to define your variables. If you do that, your erroring out line would have complained that variable 'Filename' was not defined.
As far as your next line goes:
Set varSheetA = File_Path1.Worksheets("Sheet1").Range(kRange)
you have two problems. First, when opening a csv file the tab name is always the same as the filename and NOT Sheet1. Second, kRange is part of the worksheet you started on so to get the comparable range on the new sheet you should use kRange.Address. Those fixes change the above into:
Set varSheetA = File_Path1.Worksheets("Test_File1").Range(kRange.Address)
Your loop treats ranges like arrays. The most direct way to fix that is to force them to be arrays by changing the Dim statements (adding parentheses) and the assignment statements for your range variables (removing Set and adding .Value).
Dim varSheetA() As Variant
...
varSheetA = File_Path1.Worksheets("Test_File1").Range(kRange.Address).Value
...
If varSheetA(iRow, 1) = varSheetB(iRow, 1) Then
The best alternative method is to never create the range variables in the first place and just grab cells by row and column indices.
Sub CompareLists_2()
Dim count As Integer
Dim LastRow As Long, iRow As Long
Dim MainSht As Worksheet, ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
Set MainSht = ActiveSheet
LastRow = MainSht.Range("A" & Rows.count).End(xlUp).Row
Set ws1 = Workbooks.Open(Filename:="C:\Test Files\Test_File1.csv").Worksheets("Test_File1")
Set ws2 = Workbooks.Open(Filename:="C:\Test Files\Test_File2.csv").Worksheets("Test_File2")
Set ws3 = Workbooks.Open(Filename:="C:\Test Files\Test_File3.csv").Worksheets("Test_File3")
For iRow = 3 To LastRow
count = 1
If ws1.Cells(iRow, 1).Value = ws2.Cells(iRow, 1).Value Then
count = count + 1
Else
If ws1.Cells(iRow, 1).Value = ws3.Cells(iRow, 1).Value Then
count = count + 1
Else
If count < 3 Then
MainSht.Cells(iRow, 1).Interior.ColorIndex = 3
End If
End If
End If
Next
End Sub
Of course as far as I can tell your boolean logic reduces to:
If ws1.Cells(iRow, 1).Value <> ws2.Cells(iRow, 1).Value And ws1.Cells(iRow, 1).Value <> ws3.Cells(iRow, 1).Value And ws2.Cells(iRow, 1).Value <> ws3.Cells(iRow, 1).Value Then
MainSht.Cells(iRow, 1).Interior.ColorIndex = 3
End If
Revision of boolean logic per comments (though I'm slightly confused on the logic):
If ws1.Cells(iRow, 1).Value <> ws2.Cells(iRow, 1).Value And ws1.Cells(iRow, 1).Value <> ws3.Cells(iRow, 1).Value And ws2.Cells(iRow, 1).Value <> ws3.Cells(iRow, 1).Value Then
ws1.Cells(iRow, 1).Interior.ColorIndex = 3
ElseIf ws1.Cells(iRow, 1).Value = ws2.Cells(iRow, 1).Value And ws1.Cells(iRow, 1).Value <> ws3.Cells(iRow, 1).Value Then
ws1.Cells(iRow, 1).Interior.ColorIndex = 3
ws2.Cells(iRow, 1).Interior.ColorIndex = 3
End If
Sub CompareLists()
Dim count As Integer
Dim LastRow As Long, iRow As Long
Dim MainSht As Worksheet, ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet, ws4 As Worksheet
Dim ws5 As Workbook
Dim var1 As Variant
Set ws1 = Workbooks.Open(Filename:="C:\Test Files\Test_File1.csv").Worksheets("Test_File1")
Set ws2 = Workbooks.Open(Filename:="C:\Test Files\Test_File2.csv").Worksheets("Test_File2")
Set ws3 = Workbooks.Open(Filename:="C:\Test Files\Test_File3.csv").Worksheets("Test_File3")
Set MainSht = ws1
LastRow = MainSht.Range("A" & Rows.count).End(xlUp).Row
For iRow = 3 To LastRow
count = 1
If ws1.Cells(iRow, 1).Value <> ws2.Cells(iRow, 1).Value And ws1.Cells(iRow, 1).Value <> ws3.Cells(iRow, 1).Value Then
ws1.Cells(iRow, 1).Interior.ColorIndex = 3
ElseIf ws1.Cells(iRow, 1).Value = ws2.Cells(iRow, 1).Value And ws1.Cells(iRow, 1).Value <> ws3.Cells(iRow, 1).Value Then
ws1.Cells(iRow, 1).Interior.ColorIndex = 6
ws2.Cells(iRow, 1).Interior.ColorIndex = 6
ElseIf ws1.Cells(iRow, 1).Value = ws3.Cells(iRow, 1).Value And ws1.Cells(iRow, 1).Value <> ws2.Cells(iRow, 1).Value Then
ws1.Cells(iRow, 1).Interior.ColorIndex = 6
ws3.Cells(iRow, 1).Interior.ColorIndex = 6
End If
If ws3.Cells(iRow, 1).Value <> ws2.Cells(iRow, 1).Value And ws3.Cells(iRow, 1).Value <> ws1.Cells(iRow, 1).Value Then
ws3.Cells(iRow, 1).Interior.ColorIndex = 3
ElseIf ws3.Cells(iRow, 1).Value = ws2.Cells(iRow, 1).Value And ws3.Cells(iRow, 1).Value <> ws1.Cells(iRow, 1).Value Then
ws3.Cells(iRow, 1).Interior.ColorIndex = 6
ws2.Cells(iRow, 1).Interior.ColorIndex = 6
End If
If ws2.Cells(iRow, 1).Value <> ws3.Cells(iRow, 1).Value And ws2.Cells(iRow, 1).Value <> ws1.Cells(iRow, 1).Value Then
ws2.Cells(iRow, 1).Interior.ColorIndex = 3
End If
Next
End Sub

Tabulate test scores

I am working on vba code and would like to do the following:
Read:
A B
1 John 100
2 Jill 90
3 John 95
4 Amy 82
Change to (in alphabetical order):
A B C
1 Amy 82
2 Jill 90
3 John 100 95
Ultimately i need it to display the student's name and all scores next to the name.
So far i have this:
Sub Combine()
Dim J As Integer
Dim wrk As Workbook 'Workbook object - Always good to work with object variables
Dim wrk1 As Worksheet
Dim r1, r2, r3, r4, r5, r6, r7, ra, rb, rc, rd, re, rf, rg As Range
Sheets("Sheet2").Select
Set r1 = Range("D:D")
Set r2 = Range("B:B")
Set r3 = Range("E:E")
Set r4 = Range("C:C")
Set r5 = Range("F:F")
Set r6 = Range("H:H")
Set r7 = Range("AX:AX")
Sheets("Sheet3").Select
Set ra = Range("D:D")
Set rb = Range("B:B")
Set rc = Range("E:E")
Set rd = Range("C:C")
Set re = Range("F:F")
Set rf = Range("H:H")
Set rg = Range("AX:AX")
Set wrk = Workbooks.Add
ActiveWorkbook.Sheets(2).Activate
r1.Copy Range("A1")
r2.Copy Range("B1")
r3.Copy Range("C1")
r4.Copy Range("D1")
r5.Copy Range("E1")
r6.Copy Range("F1")
r7.Copy Range("G1")
ActiveWorkbook.Sheets(3).Activate
ra.Copy Range("A1")
rb.Copy Range("B1")
rc.Copy Range("C1")
rd.Copy Range("D1")
re.Copy Range("E1")
rf.Copy Range("F1")
rg.Copy Range("G1")
On Error Resume Next
Sheets(1).Select
Sheets(1).Name = "Combined"
Sheets(2).Activate
Range("A2").EntireRow.Select
Selection.Copy Destination:=Sheets(1).Range("A1")
For J = 2 To Sheets.Count
Sheets(J).Activate
Range("A3").Select
Selection.CurrentRegion.Select
Selection.Offset(1, 0).Resize(Selection.Rows.Count - 1).Select
Selection.Copy Destination:=Sheets(1).Range("A65536").End(xlUp)(2)
Sheets(1).Select
Range("A1:AY100").Sort _
Key1:=Range("C1"), Key2:=Range("B1"), Header:=xlYes
Next
End Sub
I would create a pivot table for your case. It's easy to create, updates easily and good to maintain. However, here is some piece of code:
Sub pivotDataInColumns()
Dim sourceSheet As Excel.Worksheet
Dim destinationSheet As Excel.Worksheet
Dim sourceRow As Long
Dim destinationRow As Long
Dim matchRow As Long
Dim searchColumn As Excel.Range
Dim nameToFind As String
Dim lastColumn As Long
Application.ScreenUpdating = False
With ThisWorkbook
'Change Worksheet name to suit:
Set sourceSheet = ThisWorkbook.Worksheets("Sheet1")
Set destinationSheet = ThisWorkbook.Worksheets.Add
End With
Set searchColumn = destinationSheet.Columns("A")
For sourceRow = 1 To getLastRow(sourceSheet.Columns("A"))
nameToFind = sourceSheet.Cells(sourceRow, "A").Value
destinationRow = getMatchRow(nameToFind, searchColumn)
If destinationRow = 0 Then
destinationRow = getLastRow(destinationSheet.Columns("A")) + 1
destinationSheet.Cells(destinationRow, "A").Value = sourceSheet.Cells(sourceRow, "A").Value
End If
lastColumn = getLastColumn(destinationSheet.Rows(destinationRow)) + 1
destinationSheet.Cells(destinationRow, lastColumn).Value2 = sourceSheet.Cells(sourceRow, "B").Value2
Next sourceRow
'Remove row 1 garbage and sort:
With destinationSheet
.Rows(1).Delete
.UsedRange.Sort Key1:=.Range("A1"), _
Order1:=xlAscending, _
Header:=xlNo
End With
Application.ScreenUpdating = True
MsgBox "Data processed successfully.", vbInformation
End Sub
Private Function getMatchRow(searchValue As Variant, _
searchArray As Variant) As Long
'This function returns 0 if searchValue is not on searchArray.
Dim element As Long
On Error Resume Next
element = WorksheetFunction.Match(CDbl(searchValue), searchArray, 0)
If element = 0 Then element = WorksheetFunction.Match(CStr(searchValue), searchArray, 0)
getMatchRow = element
End Function
Private Function getLastRow(sourceRange As Excel.Range) As Long
Dim parentSheet As Excel.Worksheet
Dim lastRow As Long
Set parentSheet = sourceRange.Parent
With parentSheet
lastRow = .Cells(.Rows.Count, sourceRange.column).End(xlUp).row
End With
getLastRow = lastRow
End Function
Private Function getLastColumn(sourceRange As Excel.Range) As Long
Dim parentSheet As Excel.Worksheet
Dim lastColumn As Long
Set parentSheet = sourceRange.Parent
With parentSheet
lastColumn = .Cells(sourceRange.row, .Columns.Count).End(xlToLeft).column
End With
getLastColumn = lastColumn
End Function

Compare column A with column C, Move matching Cell from location to column B on corresponding row

Sub Match()
Dim var As Variant, iSheet As Integer, iRow As Long, iRowL As Long, bln As Boolean, rng1 As Range, rng2 As Range, i As Long, j As Long
If Not IsEmpty(rng1) Then
For i = 1 To Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
Set rng1 = Sheets("Sheet1").Range("A" & i)
For j = 1 To Sheets("Sheet1").Range("C" & Rows.Count).End(xlUp).Row
Set rng2 = Sheets("Sheet1").Range("C" & j)
bln = False
var = Application.Match(rng1.Value, rng2, 0)
If Not IsError(var) Then
bln = True
Exit For
Exit For
End If
Set rng2 = Nothing
Next j
Set rng1 = Nothing
Next i
For i = 1 To Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
Set rng1 = Sheets("Sheet1").Range("A" & i)
If bln = False Then
Cells(rng1).Font.Bold = False
Else
Cells(rng1).Font.Bold = True
End If
Next i
End If
Application.ScreenUpdating = True
End Sub
Sub CompareAndHighlight()
Dim rng1 As Range, rng2 As Range, i As Long, j As Long
For i = 1 To Sheets("sheet1").Range("C" & Rows.Count).End(xlUp).Row
Set rng1 = Sheets("sheet1").Range("C" & i)
For j = 1 To Sheets("sheet2").Range("C" & Rows.Count).End(xlUp).Row
Set rng2 = Sheets("sheet2").Range("C" & j)
If StrComp(Trim(rng1.Text), Trim(rng2.Text), vbTextCompare) = 0 Then
rng1.Interior.Color = RGB(255, 255, 0)
End If
Set rng2 = Nothing
Next j
Set rng1 = Nothing
Next i
End Sub
I am trying to compare the data column A with the data in column C
However the challenge is , If there is a match I will then need to move the cell from column C to column B on the corresponding row.
Unfortunately I can not post pictures yet, I hope this is clear enough for someone to support me with?
I have improvised to use the "code snippet to display how the data should look assuming they are arranged in Columns A B and C
Before
A12334 A12352
A12335 A12353
A12336 A12339
A12337 A12340
A12338 A12341
A12339 A12354
A12340 A12355
A12341 A12356
A12342 A22354
A12343 A22356
A12344 A22358
A12345 A22360
A12346 A22362
A12347 A22364
A12348 A22366
A12349 A22368
A12350 A22370
A12351 A22372
A12352 A12357
A12353 A12358
A12354 A12334
A12355 A12335
A12356 A12336
A12357 A12337
A12358 A12338
A12359 A22370
A12360 A22372
A12361 A12361
After:
A12334 A12334
A12335 A12335
A12336 A12336
A12337 A12337
A12338 A12338
A12339 A12339
A12340 A12340
A12341 A12341
A12342 A22354
A12343 A22356
A12344 A22358
A12345 A22360
A12346 A22362
A12347 A22364
A12348 A22366
A12349 A22368
A12350 A22370
A12351 A22372
A12352 A12352
A12353 A12353
A12354 A12354
A12355 A12355
A12356 A12356
A12357 A12357
A12358 A12358
A12359 A22370
A12360 A22372
A12361 A12361
Try this to get to your original need: (Not sure what your sheet names are so you might need to edit to reflect correct sheet.)
Sub CompareAndMove()
Dim rng1 As Range, rng2 As Range, i As Long, iL As Long, var As Range, j As Long, ws1 As Worksheet, Chk As Range, LastDest As Long
Set ws1 = Sheets("Sheet1")
iL = ws1.Range("A" & Rows.Count).End(xlUp).Row
For j = 3 To 5
Set rng2 = ws1.Range(ws1.Cells(2, j), ws1.Cells(ws1.Cells(Rows.Count, j).End(xlUp).Row, j))
For i = 2 To iL
Set rng1 = ws1.Range("A" & i)
Set var = rng2.Find(rng1.Value, LookIn:=xlValues, LookAt:=xlWhole)
If Not var Is Nothing Then
rng1.Interior.Color = RGB(255, 255, 0)
rng1.Copy
rng1.Offset(0, 1).PasteSpecial
End If
Next i
ws1.Range("B2:B" & ws1.Range("B" & Rows.Count).End(xlUp).Row).Copy
LastDest = Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Row + 1
Sheets("Sheet2").Cells(LastDest, 1).PasteSpecial xlPasteValues
LastDest = Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Row
Set rng3 = Sheets("Sheet2").Range("A2:A" & LastDest)
For each Chk in rng3
If Len(Chk.Value) = 0 Then
Chk.EntireRow.Delete xlShiftUp
End If
Next Chk
ws1.Range("B:B").Clear
Next j
End Sub
Sub CompareAndMove()
Dim rng1 As Range, rng2 As Range, i As Long, iL As Long, var As Variant
iL = Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To iL
Set rng1 = Sheets("Sheet1").Range("A" & i)
Set rng2 = Sheets("Sheet1").Range("C:C")
var = Application.Match(rng1.Value, rng2, 1)
If Not IsError(Application.Match(rng1.Value, rng2, 0)) Then
bln = True
If bln = True Then
rng1.Interior.Color = RGB(255, 255, 0)
rng1.Copy
rng1.Offset(0, 1).PasteSpecial
End If
Set rng1 = Nothing
Set rng2 = Nothing
End If
Next i
End Sub
Sub CompareAndMove()
Dim rng1 As Range, rng2 As Range, i As Long, iL As Long, var As Range, j As Long, ws1 As Worksheet, rng3 As Range, rng4 As Range, lRows As Long, lRows2 As Long, jL
Set ws1 = Sheets("Comparison Sheet")
Set ws2 = Sheets("Comparison Sheet Final")
iL = ws1.Range("A" & Rows.Count).End(xlUp).Row
jL = ws1.Cells(2, Columns.Count).End(xlToLeft).Column
For j = 3 To jL
Set rng2 = ws1.Range(ws1.Cells(2, j), ws1.Cells(ws1.Cells(Rows.Count, j).End(xlUp).Row, j))
For i = 2 To iL
Set rng1 = ws1.Range("A" & i)
Set var = rng2.Find(rng1.Value, LookIn:=xlValues, LookAt:=xlWhole)
If Not var Is Nothing Then
rng1.Interior.Color = RGB(255, 255, 0)
rng1.Offset(0, 1).Font.Name = "Wingdings"
rng1.Offset(0, 1).Value = ChrW(&HFC)
End If
Next i
ws1.Cells(2, 2) = ws1.Cells(2, j)
lRows = ws1.Cells(Rows.Count, "A").End(xlUp).Row
Set rng3 = ws1.Range(ws1.Cells(2, 2), ws1.Cells(lRows, 2))
lRows2 = ws2.Cells(Rows.Count, "A").End(xlUp).Row
lCols = j - 1
Set rng4 = ws2.Range(ws2.Cells(2, lCols), ws2.Cells(lRows, lCols))
rng4.Font.Name = "Wingdings"
rng4.Value = rng3.Value
rng3.ClearContents
ws2.Rows(2).Font.Name = "Calibri"
Next j
End Sub
How it currently looks with your code with slight edits