I have a VBA spreadsheet that allows a user to add the contents of another spreadsheet, format it, calculate totals, and add a pie chart. It is mostly working fine except there is one month tab that is creating a series per data point when we want all data points in one pie.
Here is the function to create the pie chart.
Sub AddChart(CurrentWorkSheet As Worksheet)
Dim FirstRow As Integer
Dim LastRow As Integer
Dim FirstColumn As String
Dim LastColumn As String
Dim DataRange As Range
Dim i As Integer
FirstRow = RowCount(CurrentWorkSheet) + 2
LastRow = FirstRow + 4
Set DataRange = CurrentWorkSheet.Range("I" & FirstRow & ":I" & LastRow)
Dim MyChart As Chart
Set MyChart = CurrentWorkSheet.Shapes.AddChart(xlPie).Chart
MyChart.SetSourceData Source:=DataRange
MyChart.SeriesCollection(1).HasDataLabels = True
For i = 1 To MyChart.SeriesCollection(1).Points.Count
If i = 1 Then
MyChart.SeriesCollection(1).Points(i).Interior.Color = RGB(0, 176, 80)
ElseIf i = 2 Then
MyChart.SeriesCollection(1).Points(i).Interior.Color = RGB(255, 0, 0)
ElseIf i = 3 Then
MyChart.SeriesCollection(1).Points(i).Interior.Color = RGB(112, 48, 160)
ElseIf i = 4 Then
MyChart.SeriesCollection(1).Points(i).Interior.Color = RGB(0, 0, 0)
MyChart.SeriesCollection(1).Points(i).DataLabel.Font.Color = RGB(255, 255, 255)
ElseIf i = 5 Then
MyChart.SeriesCollection(1).Points(i).Interior.Color = RGB(0, 112, 192)
Else
End If
Next
MyChart.SeriesCollection(1).XValues = CurrentWorkSheet.Range("H" & CStr(FirstRow) & ":H" & CStr(LastRow))
End Sub
In this workbook there is a YTD worksheet and a worksheet for each month. When it gets to April the pie has one color. All of the other months are fine.
The data set is as follows:
ATTACHMENT 962.31
DAMAGE 3,279.94
MODIFICATIONS 451.00
REPAIRS 5,239.78
TIRES 1,979.04
The data range is rows 51-55.
=SERIES(,'Apr 2014'!$H$51:$H$55,'Apr 2014'!$I$51,1)
When I look at the series in Excel there are 5 listed, the first is ATTACHMENT and the last 4 are 1. Each month is using the same function as well as the YTD tab and they are all OK except April.
Any ideas what could be causing it?
I think I figured it out. I changed the following
Set DataRange = CurrentWorkSheet.Range("I" & FirstRow & ":I" & LastRow)
to
Set DataRange = CurrentWorkSheet.Range("I" & CStr(FirstRow) & ":I" & CStr(LastRow))
Seems to be working now. Unsure why it worked OK on the other tabs....
Related
Whole Code Explained:
I have this code that saves a txt file as a Microsoft Excel Comma Separated Values File (.csv) then opens a blank template excel file with a sheet named Graphs. It then copies the sheet with all the data from the csv file into the template excel file, renames it to "data" Then deletes the csv after close. The code then Inserts a chart in the "graph" sheet. Next it finds the total number of rows used and number of columns used for references for the ranges in the graphs and then for later formulas. This data is Acceleration from a accelerometer at a specific frequency. Therefor there is a lot of data, 8193 rows! The data lay out is top row labels (hz, Part1, 2...), Column A is frequencys, and all other cells from B2:whatever is accelerometer readings.
The Problem is it takes 83.22 seconds
to do the following loop, which inserts the average formula:
Do While i <= LastRow
'Assign Range To Take Average
CellLeft = wbtempXl.Worksheets("Data").Cells(i, 2)
CellRight = wbtempXl.Worksheets("Data").Cells(i, LastColumn)
AvgRange = wbtempXl.Worksheets("Data").Range(CellLeft, CellRight)
Average = appXL.WorksheetFunction.Average(AvgRange)
wbtempXl.Worksheets("Data").Cells(i, LastColumn + 1).Value = Average
i = i + 1
Loop
After this Average formula I am adding peak finding logic to find the peaks and troughs in the data, but this step alone takes a minute and a half. Is there a fast, better way of doing this? Looping formulas that is.
Note: I can not just have the formulas in the template. The test could include 12 parts or 100 parts. Each part has its own column and the frequency is in the rows of column A. The rest of the Rows is acceleration readings per frequency. Would post picture but not allowed to yet.
Full Code:
Public Sub btn_Do_Click(sender As Object, e As EventArgs) Handles btn_Do.Click
Dim FileTXT As String = cbo_FileList.Text
Dim folderpath As String = "C:\Users\aholiday\Desktop\Data Dump"
Dim txtpath As String = folderpath & "\" & FileTXT & ".txt"
Dim csvpath As String = "C:\Temp\" & FileTXT & ".csv"
Dim FinalFile As String = "C:\Users\aholiday\Desktop\Test"
Try
File.Copy(txtpath, csvpath)
Catch
MsgBox("Please Choose File")
Exit Sub
End Try
appXL = CreateObject("Excel.Application")
appXL.Visible = True
wbcsvXl = appXL.Workbooks.Open(csvpath)
wbtempXl = appXL.Workbooks.Open(FinalFile)
wbcsvXl.Worksheets(FileTXT).Copy(After:=wbtempXl.Worksheets("Graphs"))
wbtempXl.Worksheets(FileTXT).Name = ("Data")
'Close Objects
wbcsvXl.Close()
File.Delete(csvpath)
'Release Objects
wbcsvXl = Nothing
' Declare Varables
Dim Chart As Excel.Chart
Dim ChartXL As Excel.ChartObjects
Dim ThisChart As Excel.ChartObject
Dim SerCol As Excel.SeriesCollection
Dim Series As Excel.Series
Dim xRange As Excel.Range
Dim xCelltop As Excel.Range
Dim xCellBottom As Excel.Range
Dim yRange As Excel.Range
Dim yCelltop As Excel.Range
Dim yCellBottom As Excel.Range
Dim CellRight As Excel.Range
Dim CellLeft As Excel.Range
Dim AvgRange As Excel.Range
Dim Average As Double
Dim LastRow As Long
Dim LastColumn As Long
Dim i As Integer
' Set i integer
i = 2
'Make Chart
ChartXL = wbtempXl.Worksheets("Graphs").ChartObjects
ThisChart = ChartXL.Add(0, 0, 800, 400)
Chart = ThisChart.Chart
Chart.ChartType = Excel.XlChartType.xlXYScatterSmoothNoMarkers
With ThisChart.Chart
.HasTitle = True
.ChartTitle.Characters.Text = "RF Graph"
' X,Y title??????
End With
'Count Rows Used
'Find last Row Used
With wbtempXl.Worksheets("Data")
LastRow = .UsedRange.Rows.Count
End With
'Count Columns Used
'Find Last Column Used
With wbtempXl.Worksheets("Data")
LastColumn = .UsedRange.Columns.Count
End With
Do Until i > LastColumn
'Excel Chart X Axis Values
xCelltop = wbtempXl.Worksheets("Data").Cells(2, 1)
xCellBottom = wbtempXl.Worksheets("Data").Cells(LastRow, 1)
xRange = wbtempXl.Worksheets("Data").Range(xCelltop, xCellBottom)
'Excel Chart Y Axis Values
yCelltop = wbtempXl.Worksheets("Data").Cells(2, i)
yCellBottom = wbtempXl.Worksheets("Data").Cells(LastRow, i)
yRange = wbtempXl.Worksheets("Data").Range(yCelltop, yCellBottom)
'Label Part in Data Sheet
wbtempXl.Worksheets("Data").Cells(1, i).Value = ("Rotor " & i - 1)
'Add New Series to Chart
SerCol = Chart.SeriesCollection
Series = SerCol.NewSeries
'Rename and Assign Values
With Series
.Name = ("Rotor " & i - 1)
Series.XValues = xRange
Series.Values = yRange
End With
Chart.Refresh()
i = i + 1
Loop
'Add Average Column Label
wbtempXl.Worksheets("Data").Cells(1, LastColumn + 1).Value = "Average"
'Rest i integer
i = 2
Do While i <= LastRow
'Assign Range To Take Average
CellLeft = wbtempXl.Worksheets("Data").Cells(i, 2)
CellRight = wbtempXl.Worksheets("Data").Cells(i, LastColumn)
AvgRange = wbtempXl.Worksheets("Data").Range(CellLeft, CellRight)
Average = appXL.WorksheetFunction.Average(AvgRange)
wbtempXl.Worksheets("Data").Cells(i, LastColumn + 1).Value = Average
i = i + 1
Loop
'Release Objects
wbtempXl = Nothing
appXL = Nothing
GC.Collect()
Me.Close()
End Sub
I'd suggest you put formulas in the cells with code then convert to values if required:
With wbtempXl.Worksheets("Data")
formularange = .Range(.Cells(i, LastColumn + 1), .Cells(LastRow, LastColumn + 1))
End With
formularange.FormulaR1C1 = "=AVERAGE(RC2:RC[-1])"
formularange.Value2 = formularange.Value2
I'm writing a code to populate a data table then take and save an image of it by calling a module someone else made. My portion of the code is able to create the image and the sub that gets called works for creating images for other tables, but I think something is missing in my portion. This is the for loop to cycle through different product lines and create images of their tables.
For i = 0 To UBound(allLines)
Cells(bcell, 2) = Cells(product, 2)
Cells(bcell, 3) = Cells(product, 3)
Cells(bcell, 4) = Cells(product, 4)
Cells(bcell, 5) = Cells(product, 5)
Cells(ecell, 2) = Cells(product, 6)
Cells(ecell, 3) = Cells(product, 7)
Cells(ecell, 4) = Cells(product, 8)
Cells(ecell, 5) = Cells(product, 10)
Range(Cells(acell, 1), Cells(ecell, 5)).Select
Selection.Copy
Range("M14").Select
ActiveSheet.Pictures.Paste.Select
myfilename = Year(Now) & " " & MonthName(Month(Now)) & " " & allLines(i) & " Production Status Metrics" ' & ".jpg"
EndFilePath = "C:\Users\*******\Documents\**********\TEST FILES\" & myfilename 'edited for privacy
Call ExportMyPicture(allLines(i), EndFilePath) 'Module: Export_Cells_to_File
Range("A1").Select
acell = acell + 5
ecell = ecell + 5
bcell = bcell + 5
product = product + 1
Next
This is the sub that gets called up to the line that gives me an error
Sub ExportMyPicture(SelectedLine As String, EndFilePath As String)
Dim MyChart As String, MyPicture As String
Dim PicWidth As Long, PicHeight As Long
Application.ScreenUpdating = False
MyPicture = Selection.Name
With Selection
PicHeight = .ShapeRange.Height
PicWidth = .ShapeRange.Width
End With
Charts.Add
ActiveChart.Location Where:=xlLocationAsObject, Name:=SelectedLine & " Actions" 'This line gives the error
The error message reads object variable or with block variable not set
It seems that you are trying to make an embedded chart. In this case the chart has a container object called a chart object which sits between the chart and the containing sheet. Rather than creating a chart and then adjusting its location, you can add it as a chart object in the target sheet. Something like:
Sub test()
Dim mySheet As Worksheet
Set mySheet = Sheets(1)
Dim PicWidth As Long, PicHeight As Long
PicWidth = 200
PicHeight = 100
Dim CO As ChartObject
Dim CH As Chart
Set CO = mySheet.ChartObjects.Add(10, 10, PicWidth, PicHeight)
Set CH = CO.Chart
CH.ChartType = xlXYScatter
CO.Activate
End Sub
The 4 parameters of the Add method are left, top. width, height.
I hope I make this clear:
I have a loop that copies some hyperlinks in specific cells (they come from a document list with the file path, document name, etc stored in another sheet).
I would like to have an icon next to the hyperlink that indicates if it will open a word document, a folder, etc. In the document list, I can put an indicator in the column next to the hyperlink (1 for word doc, 2 for folder, etc) so that depending on the case, the right icon gets sent next to the right type of document hyperlink.
I have managed to do it by simply inserting shapes (blue rectangle for word doc, green for folder) but I'd like to have a more descriptive symbol (like a specific FaceID maybe?). Here is my code (dumbed down for simplicity):
Sub Icons()
Dim i As Integer
Dim sh As Object
'Only loops through A1:A5 for simplicity
'Looks at the associated indicator located in the previous sheet
'Assigns a shape depending if it is 1 or 2
For i = 1 To 5
If Feuil1.Range("A" & i) = "1" Then
Set sh = Feuil2.Shapes.AddShape(msoShapeRectangle, Range("A"& i).Left, Range("A" & i).Top, 15, 15)
sh.Name = "WordDocIcon" & i
sh.Fill.ForeColor.RGB = RGB(0, 220, 220)
End If
If Feuil1Range("A" & i) = "2" Then
'It is easy to do when inserting a given msoShape, but I want something else!
Set sh = Feuil2.Shapes.AddShape(msoShapeRectangle, Range("A" & i).Left, Range("A" & i).Top, 15, 15)
sh.Name = "FolderIcon" & i
sh.Fill.ForeColor.RGB = RGB(100, 100, 0)
End If
Next
End Sub
Further to my comments, Here is how you can insert pictures and position them in say Column B. I would still say that typing "Word" or "Folder" in Column B and then coloring the cell would be much simpler :)
Sub Sample()
Dim ws As Worksheet
Dim picWord As String
Dim picFolder As String
Dim Shp As Shape
Dim i As Long
picWord = "C:\Users\Siddharth\Desktop\Word.Jpg"
picFolder = "C:\Users\Siddharth\Desktop\folder.Jpg"
Set ws = ThisWorkbook.Sheets("Feuil1")
With ws
For i = 1 To 5
If .Range("A" & i) = "1" Then
With .Pictures.Insert(picWord)
With .ShapeRange
.LockAspectRatio = msoTrue
.Width = ws.Range("B" & i).Width
.Height = ws.Range("B" & i).Height
End With
.Left = ws.Range("B" & i).Left
.Top = ws.Range("B" & i).Top
.Placement = 1
.PrintObject = True
End With
ElseIf .Range("A" & i) = "2" Then
With .Pictures.Insert(picFolder)
With .ShapeRange
.LockAspectRatio = msoTrue
.Width = ws.Range("B" & i).Width
.Height = ws.Range("B" & i).Height
End With
.Left = ws.Range("B" & i).Left
.Top = ws.Range("B" & i).Top
.Placement = 1
.PrintObject = True
End With
End If
Next i
End With
End Sub
I used the following pictures. You can download these or use whatever you like.
When you run the above code, you will get this kind of output
OK, I've got a straight-forward 2-d block of data in excel: row 1 and column 1 are labels, the rest are numbers. My task right now is to put the sum of each column in the first empty cell(row) underneath.
Whereas my practice dataset is of known dimensions, the actual datasets I'll be using this program on will have a variable number of rows and columns. To this end, I can't just say "=SUM(B2:B20)" because the last filled cell won't always be B20 (for example). The easiest way to total each column, I thought, would be a FOR..NEXT loop, but I just can't get VS to accept the summation formula. Here's what I've got so far:
`With xlWsheet2 'check for last filled row and column of transposed data'
If xlApp.WorksheetFunction.CountA(.Cells) <> 0 Then
lRow2 = .Cells.Find(What:="*",
After:=.Cells(1, 1),
LookAt:=Excel.XlLookAt.xlPart,
LookIn:=Excel.XlFindLookIn.xlFormulas,
SearchOrder:=Excel.XlSearchOrder.xlByRows,
SearchDirection:=Excel.XlSearchDirection.xlPrevious,
MatchCase:=False).Row
Else : lRow2 = 1
End If
If xlApp.WorksheetFunction.CountA(.Cells) <> 0 Then
lCol2 = .Cells.Find(What:="*",
After:=.Range("A1"),
LookAt:=Excel.XlLookAt.xlPart,
LookIn:=Excel.XlFindLookIn.xlFormulas,
SearchOrder:=Excel.XlSearchOrder.xlByRows,
SearchDirection:=Excel.XlSearchDirection.xlPrevious,
MatchCase:=False).Column
Else : lCol2 = 1
End If
lastcell2 = xlWsheet2.Cells(lRow2, lCol2) 'defines last row, column of transposed data'
emptyRow1 = xlWsheet2.Rows(lRow2).Offset(1) 'defines the first empty row'
'add in cell of SUM underneath each column'
For i As Integer = 2 To lCol2
colTop = xlWsheet2.Cells(2, i)
colBot = xlWsheet2.Cells(lRow2, i)
ELtotal = xlWsheet2.Range(emptyRow1, i)
ELtotal = .Sum(.Range(colTop, colBot))
Next i
End With
`
Now, the ELtotal statements used to be one long line, but I was trying to see what part VS had a problem with. It breaks at the first one, .Range(emptyRow1, i). Here's other iterations of that equation I've tried that weren't accepted:
.Range(emptyRow1, I).Formula = "=SUM(colTop, colBot)"
.Range(emptyRow1, I).Formula = "=SUM(.cells(2,i), (lRow2,i))"
.Range(emptyRow1, I).Formula = .sum(.range(colTop, colBot)
.Range(emptyRow1, I).Value = etc...
ad inifintum
PS- I'm pretty new to this, so I'm probably going about this whole process the wrong way...
Based on what you told me about the row and column headings, I believe that this code will do what you want, namely put a single column sum in the first empty cell underneath.
Sub find()
Dim lastrow As Long, lastcol As Long, thiscol As Long
lastrow = Cells(Rows.Count, 1).End(xlUp).Row
lastcol = Cells(1, Columns.Count).End(xlToLeft).Column
For thiscol = 2 To lastcol
Cells(lastrow + 1, thiscol).Select
ActiveCell.Value = WorksheetFunction.Sum(Range(Cells(1, ActiveCell.Column), ActiveCell))
Next
End Sub
Best of luck.
This formula will do the trick of summing two whole columns, A and B in this case:
= sum($A:$B)
If it is possible for the headers to be interpreted as numeric values that might contribute to the sum then the formula should be amended to be
= sum($A:$B) - sum($A$1:$B$1)
In order to export to excel with sum of all numeric columns from DataGridView, add a button to your form and add the following code in its click event:-
Private Sub Button4_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button4.Click
'--- Export to Excel -------------------------------------------------
Dim xlApp As Excel.Application
Dim xlWorkBook As Excel.Workbook
Dim xlWorkSheet As Excel.Worksheet
Dim misValue As Object = System.Reflection.Missing.Value
Dim i As Integer
Dim j As Integer
Dim datarange As Excel.Range
Dim save_file As New SaveFileDialog
'give its extension
''save_file.Filter = "xls files (*.xls)|*.xls|All files (*.*)|*.*"
'save_file.Filter = "xls files (*.xls)|*.xls"
save_file.Filter = "xls files (*.xls)|*.xls|Excel 2007|*.xlsx"
''Select xls
save_file.FilterIndex = 2
save_file.FileName = "My_excel_report_"
save_file.RestoreDirectory = True
Try
If save_file.ShowDialog() = DialogResult.OK Then
xlApp = New Excel.ApplicationClass
xlWorkBook = xlApp.Workbooks.Add(misValue)
xlWorkSheet = xlWorkBook.Sheets("sheet1")
For x = 0 To DataGridViewSummary1.ColumnCount - 1
xlWorkSheet.Cells(0 + 1, x + 1) = _
DataGridViewSummary1.Columns(x).HeaderText
Next
For i = 0 To DataGridViewSummary1.RowCount - 1
For j = 0 To DataGridViewSummary1.ColumnCount - 1
If IsDate(DataGridViewSummary1(j, i).Value) Then
'MsgBox("The cell value is date")
xlWorkSheet.Cells(i + 2, j + 1) = FormatDateTime(CDate(DataGridViewSummary1(j, i).Value.ToString), DateFormat.ShortDate)
xlWorkSheet.Cells(i + 2, j + 1).HorizontalAlignment = Excel.Constants.xlCenter
xlWorkSheet.Cells(i + 2, j + 1).VerticalAlignment = Excel.Constants.xlCenter
Else
xlWorkSheet.Cells(i + 2, j + 1) = _
DataGridViewSummary1(j, i).Value.ToString()
End If
Next
Next
datarange = xlWorkBook.ActiveSheet.UsedRange
datarange.Font.Name = "Consolas"
datarange.Font.Size = 10
'--- added on 07/09/2016 -------------------------------------------------------------------
Dim lastrow, lastcol As Long
With xlWorkSheet
lastcol = .Cells(1, .Columns.Count).End(Excel.XlDirection.xlToLeft).Column
lastrow = .Range("A" & .Rows.Count).End(Excel.XlDirection.xlUp).Row
End With
'MessageBox.Show("The last column in Sheet1 which has data is " & lastcol)
'MessageBox.Show("The last row in Col A of Sheet1 which has data is " & lastrow)
For i = 2 To lastcol
If IsNumeric(xlWorkSheet.Cells(lastrow, i).Value) Then
xlWorkSheet.Cells(lastrow + 1, i).Select()
xlWorkSheet.Cells(lastrow + 1, i).Value = xlApp.WorksheetFunction.Sum(xlWorkSheet.Range(xlWorkSheet.Cells(1, i), xlWorkSheet.Cells(lastrow + 1, i)))
End If
Next i
xlWorkSheet.Columns.AutoFit()
'----------------------------------------------------------------------------------------------
xlWorkSheet.SaveAs(save_file.FileName) 'sd.filename reurns save file dialog path
xlWorkBook.Close()
xlApp.Quit()
releaseObject(xlApp)
releaseObject(xlWorkBook)
releaseObject(xlWorkSheet)
'--------------------------------------
Dim proc As Process = Nothing
Dim startInfo As New ProcessStartInfo
startInfo.FileName = "EXCEL.EXE"
startInfo.Arguments = save_file.FileName
Process.Start(startInfo)
End If
Catch ex As Exception
MessageBox.Show(ex.ToString)
'GlobalErrorHandler(ex)
End Try
End Sub
I have 3 issues with the following piece of code:
Intention of code: I have a table of data, 4 columns (F,G, H and I) wide and X rows long (X is typically between 5 and 400). I have a list of dates in column M, typically no more than 8 dates. Column H of table, contains dates as well. I want to find the dates that are in both columns (H and M) and whenever they appear, go to the same row in column I and set its value to zero, and the one after it (so if a match was in H100, then I100 and I101 would be zeroed).
issues with code: edited 1) as per feedback.
1) I have, using an if formula (=if(H100=M12,1,0), verified that there is one match, as how the spreadsheet sees it. The macro does not find this match, despite confirmation from the if formula. Cells I100 and I101 have nonzero values, when they should be zeroed.
2) the code runs, but takes about 3 minutes to go through 3 sheets of 180 rows of data. What can be done to make it run faster and more efficiently? It could have up to 30 sheets of data, and 400 rows (extreme example but possible, in this instance im happy to let it run a bit).
3) Assuming my data table before the macro is run, is 100 rows long, starting in row 12, after the macro, column I has nonzero values for 111 rows, and zeroes for the next 389. Is there a way I can prevent it from filling down zeroes, and leaving it blank?
I am using a correlate function afterwards on column I and there huge agreement of 0's with 0's is distorting this significantly. Thanks in advance,
Sub DeleteCells()
Dim ws As Worksheet
Dim cell As Range, search_cell As Range
Dim i As Long
Dim h As Long
Application.ScreenUpdating = False
For Each ws In ThisWorkbook.Worksheets
If Not ws.Name = "Cover" Then
For Each cell In ws.Range("H12:H500")
On Error Resume Next
h = ws.Range("G" & Rows.Count).End(xlUp).Row
i = ws.Range("L" & Rows.Count).End(xlUp).Row
Set search_cell = ws.Range("M12:M" & h).Find(what:=cell.Value, LookIn:=xlValues, lookat:=xlWhole)
On Error GoTo 0
If Not search_cell Is Nothing Then
ws.Range("I" & cell.Row).Value = 0
ws.Range("I" & cell.Row + 1).Value = 0
Set search_cell = Nothing
End If
Next cell
End If
Next ws
Application.ScreenUpdating = True
Set ws = Nothing: Set cell = Nothing: Set search_cell = Nothing
End Sub
EDIT: TESTED CODE, will work for 0, 1 row of data in H/M column starting from row 12?
EDIT: Updated the cell to handle case with 1 line of data, untested :|
I will give my solution first, this one should be much faster because it read the cells into memory first
Please comment if it doesn't work or you have further question
Sub DeleteCells()
Dim ws As Worksheet
Dim i As Long
Dim h As Long
Dim MColumn As Variant ' for convinence
Dim HColumn As Variant
Dim IColumn As Variant
Application.ScreenUpdating = False
For Each ws In ThisWorkbook.Worksheets
If Not ws.Name = "Cover" Then 'matching the target sheet
' matching the rows where column M's date matches column H's date
'starting row num is 12
With ws ' for simplifying the code
h = .Range("H" & .Rows.count).End(xlUp).Row
If h = 12 Then ' CASE for 1 row only
If Range("H12").Value = Range("M12").Value Then
Range("I12:I13").Value = ""
End If
ElseIf h < 12 Then
' do nothing
Else
ReDim HColumn(1 To h - 11, 1 To 1)
ReDim MColumn(1 To h - 11, 1 To 1)
ReDim IColumn(1 To h - 10, 1 To 1)
' copying the data from worksheet into 2D arrays
HColumn = .Range("H12:H" & h).Value
MColumn = .Range("M12:M" & h).Value
IColumn = .Range("I12:I" & h + 1).Value
For i = LBound(HColumn, 1) To UBound(HColumn, 1)
If Not IsEmpty(HColumn(i, 1)) And Not IsEmpty(MColumn(i, 1)) Then
If HColumn(i, 1) = MColumn(i, 1) Then
IColumn(i, 1) = ""
IColumn(i + 1, 1) = ""
End If
End If
Next i
'assigning back to worksheet cells
.Range("H12:H" & h).Value = HColumn
.Range("M12:M" & h).Value = MColumn
.Range("I12:I" & h + 1).Value = IColumn
End If
End With
End If
Next ws
Application.ScreenUpdating = True
End Sub