I want to resize the shape of rectangle according to cell data, were height(width) of rectangle is constant and length changes according to cell References.
For EG (please refer image) : DW1 is starting side which should have Reference data from range("B13") and move along or match data to range("D4:AF4") and it should be same for another end side DW2.
DW2 should have reference from range("C13") and match data to range("D4:AF4").
I have worked on some code but it is not having proper output.
Please have a look for my code below.
new code will also be helpfull
Sub Rectanglematch()
Dim dl1 As Double
Dim dl2 As Double
Dim dw1 As Double
Dim dw2 As Double
Dim dw As Double
Dim dl As Double
Dim d As Date
Dim R As Excel.Range
dw = dw1
dw = dw2
dl = dl1
dl = dl2
d = CDate(Sheets("Tabelle1").Range("b13"))
Set R = Sheets("Tabelle1").Range("d4:AF4")
dl1 = 10 * Range("A1").Value
dl2 = 10 * Range("A1").Value
dw1 = Application.WorksheetFunction.Match(CDbl(CDate(Sheets("Tabelle1").Range("b13"))), R, 0)
dw2 = Application.WorksheetFunction.Match(CDbl(CDate(Sheets("Tabelle1").Range("c13"))), R, 0)
With ActiveSheet.Shapes("Rechteck 2")
.Top = .Top - dw + .Height
.Height = dw
.Width = dl
End With
End Sub
I'm not really sure if I got your point in 100%, but take a look at my approach to this:
Option Explicit
Sub Rectanglematch()
Dim lastRow As Long
Dim lastCol As Long
Dim heightCell As Long
Dim widthCell As Long
Dim rngDates As Range
Dim i As Long
Dim sDat As Long
Dim eDat As Long
Dim myRectangle As Shape
With ThisWorkbook.Sheets("Tabelle1")
lastRow = .Cells(Rows.Count, 2).End(xlUp).Row
lastCol = .Cells(4, Columns.Count).End(xlToLeft).Column
For i = 6 To lastRow
If .Cells(i, 2) = "" Or .Cells(i, 3) = "" Then
Else
heightCell = .Cells(i, 2).RowHeight
widthCell = .Cells(i, 2).Width
Set rngDates = .Range(.Cells(4, 4), .Cells(4, lastCol))
sDat = Application.WorksheetFunction.Match(.Cells(i, 2), rngDates, 0) + 3
eDat = Application.WorksheetFunction.Match(.Cells(i, 3), rngDates, 0) + 3
Set myRectangle = .Shapes.AddShape(msoShapeRectangle, .Cells(i, sDat).Left, .Cells(i, sDat).Top, .Cells(i, eDat).Left - .Cells(i, sDat).Left, heightCell)
End If
Next i
End With
End Sub
And the result looks like this:
Hope it will help You :)
Related
I've written the below code to modify a speadsheet that has tens of thousands of lines. Whenever I run the code, it burns through the lines fast enough, will complete about 10k lines in 3-4 minutes or so. But every time I run it, it gets to about line 25K or so, and crashes, telling me I don't have enough memory, and will suggest upgrading to 64-bit. I have a macro that created the sheet without incident, and it's much more complex, so seems odd this code crashes it. Anything in this code that you'd think would cause my issue? Or is 64-bit likely the right fix?
Sub TPOUploadCADUplicate()
'This takes the TPO Mass upload sheet and duplicates it below for Canada. Unlike above, it doesn't do anything to the US part on top
Dim Answer As String
Dim BigMarkup As Double
Dim CAPrice As Double
Dim Cost As Double
Dim i As Long
Dim rn As Long
Dim rn2 As Long
Dim SKUCount As Double
Dim STMarkup As Double
Dim USPrice As Double
Dim lr As Long
Dim DescLen As Integer
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
'Make sure you didn't accidentally leave the description length column in
If Cells(1, 3) <> "VENDOR # (9 SPACES)" Then
DescLen = MsgBox("Yo, bro. I think you left the description length column in. You want to delete that shit? I can't proceed otherwise.", vbYesNo)
If DescLen = 6 Then
Columns(3).Delete
ElseIf DescLen = 7 Then
Exit Sub
End If
End If
Columns(6).NumberFormat = "#.00"
'Loop through each one, doing the math from the TPO price calculator Connie has
If Cells(2, 1) = "" Then Exit Sub
rn = Cells(1, 1).End(xlDown).Row
rn2 = rn + 1
rn = 2
SKUCount = rn2 - rn
For i = 1 To SKUCount
Application.StatusBar = "Progress: " & i & " of " & SKUCount & " - " & Format(i / SKUCount, "0%")
Rows(rn2).Value = Rows(rn).Value
USPrice = Cells(rn, 4)
If USPrice * CAMarkup < 20 Then
CAPrice = Round((USPrice) * CAMarkup, 1) + 0.09
Else
CAPrice = WorksheetFunction.RoundDown((USPrice) * CAMarkup, 0) + 0.99
End If
Cells(rn2, 4) = CAPrice
Cells(rn2, 6).Value = Cells(rn2, 6).Value * CAMarkup
Cells(rn2, 22) = "CAM"
rn = rn + 1
rn2 = rn2 + 1
Next i
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
.StatusBar = False
End With
End Sub
Might be better (faster) to read all the data to an array, then work on the array, before putting it on the sheet after the existing data.
Sub TPOUploadCADUplicate()
Dim ans
Dim CAPrice As Double
Dim SKUCount As Double
Dim STMarkup As Double, CAMarkup As Double
Dim USPrice As Double
Dim DescLen As Integer, ws As Worksheet, arr, lr As Long, lc As Long, r As Long
Set ws = ActiveSheet 'best to be explicit about which sheet you're working with
'Make sure you didn't accidentally leave the description length column in
If ws.Cells(1, 3) <> "VENDOR # (9 SPACES)" Then
ans = MsgBox("Yo, bro. I think you left the description length column in. " & _
"You want to delete that shit? I can't proceed otherwise.", vbYesNo)
If ans <> vbYes Then Exit Sub
ws.Columns(3).Delete
End If
ws.Columns(6).NumberFormat = "#.00"
lr = ws.Cells(Rows.Count, "A").End(xlUp).Row 'last row
If lr = 1 Then Exit Sub 'no data?
lc = ws.Cells(1, Columns.Count).End(xlToLeft).Column 'last column
CAMarkup = 1.1 '<< for example
arr = ws.Range("A2", ws.Cells(lr, lc)).value 'copy the existing data as an array
For r = 1 To UBound(arr, 1) 'loop over the array and make adjustments
USPrice = arr(r, 4)
If USPrice * CAMarkup < 20 Then
CAPrice = Round((USPrice) * CAMarkup, 1) + 0.09
Else
CAPrice = WorksheetFunction.RoundDown((USPrice) * CAMarkup, 0) + 0.99
End If
arr(r, 4) = CAPrice
arr(r, 6) = arr(r, 6) * CAMarkup
arr(r, 22) = "CAM"
Next r
'put the data on the sheet
ws.Cells(lr + 1, "A").Resize(UBound(arr, 1), UBound(arr, 2)).value = arr
End Sub
I'm trying to write nested for loops to loop through the rows of a column to do some calculation then go to the next column to do it again. The logic makes sense to me, but the output to the sheet flashes back and forth between the correct answers and overwriting everything with the same number, and it just keeps doing that. Please let me know if I need to clarify on anything, thanks in advance.
Sub findAvg2()
Dim maxVal As Double
Dim preHr As Double
Dim nextHr As Double
Dim cVal As Double
Dim pVal As Double
Dim nVal As Double
Dim avg As Double
Dim maxAvg As Double
Dim i As Integer 'row
Dim j As Integer 'col
Dim lRow As Integer
Dim lCol As Integer
lRow = Cells(Rows.count, 1).End(xlUp).row 'Find the number of rows in column A(1)
lCol = Cells(1, Columns.count).End(xlToLeft).Column
For i = 19 To lRow
For j = 2 To lCol
maxVal = Cells(2, j).Value
preHr = Cells(8, j).Value
nextHr = Cells(9, j).Value
avg = (maxVal + preHr + nextHr) / 3
If Cells(i, j).Value > 0 Then
pVal = Cells(i - 1, j).Value
cVal = Cells(i, j).Value
nVal = Cells(i + 1, j).Value
maxAvg = (pVal + cVal + nVal) / 3
If avg > maxAvg Then
maxAvg = avg
End If
End If
Cells(12, j).Value = maxAvg
'Debug.Print maxAvg
Next j
Next i
End Sub
I reviewed your code and find nothing wrong with it. The modifications I did make appear to me to be of cosmetic nature. Here is the result.
Sub findAvg2()
' 005
Dim maxVal As Double
Dim preHr As Double
Dim nextHr As Double
Dim cVal As Double
Dim pVal As Double
Dim nVal As Double
Dim Avg As Double
Dim maxAvg As Double
Dim Cl As Long ' last used column
Dim Rl As Long ' last used row
Dim C As Long ' column
Dim R As Long ' row
' Find the number of used columns and roaws in the sheet
Cl = Cells(1, Columns.Count).End(xlToLeft).Column
Rl = Cells(Rows.Count, 1).End(xlUp).Row
For R = 19 To Rl
For C = 2 To Cl
maxVal = Cells(2, C).Value
preHr = Cells(8, C).Value
nextHr = Cells(9, C).Value
maxAvg = (maxVal + preHr + nextHr) / 3
cVal = Cells(R, C).Value
If cVal > 0 Then
pVal = Cells(R - 1, C).Value
nVal = Cells(R + 1, C).Value
Avg = (pVal + cVal + nVal) / 3
If Avg > maxAvg Then maxAvg = Avg
End If
Cells(12, C).Value = maxAvg
'Debug.Print maxAvg
Next C
Next R
End Sub
There is a possible weakness in this line of your code. For R = 19 To Rl. Since you are including the previous row in your calculation of averages row 18 must contain data. If it doesn't, and you can't exclude the first data row from evaluation, special provision must be made for the calculation of the initial maxAvg.
All action takes place on the ActiveSheet. This is an arrangement I instinctively dislike. Unless you are calling the sub from a button on that sheet - and even then, in case a smart alec wants to use F5 instead - I would name the sheet in the code. Use a CodeName both for greater security and to allow users the freedom to rename the sheet. This code will run on whatever sheet that happens to be active. It doesn't even have to be in the same workbook.
I'm currently working on a project which needs to build graph regarding to a table of analyses to check if the products work with time.
The user starts to choose which products he want to check and the code create a table regarding that.
The two main values are the date and the result which need to be on the graph and the third one is the batch number which needs to be the name of each chart series.
After that the code creates a 2D array with the table.
For Each elementReo In Range("tabReorganize[Date]")
ReDim Preserve tabReo(2, r)
tabReo(0, r) = elementReo
tabReo(1, r) = 0 & elementReo.Offset(0, 1)
tabReo(2, r) = elementReo.Offset(0, 2)
r = r + 1
Next elementReo
And after that I want to create the graph regarding to the number of different batch number that I have.
'This part create the Chart and set the title
Set ChartObj = ActiveSheet.ChartObjects.Add(Left:=2979.75, Width:=550, Top:=358.5, Height:=325)
ChartObj.Chart.ChartType = xlLine
ChartObj.Chart.SetElement (msoElementChartTitleAboveChart)
ChartObj.Chart.ChartTitle.Text = "Humidite"
Dim tabNBN() As String
Dim NBN As Integer
Dim checkNBN As Boolean
ReDim tabNBN(NBN)
Dim SeriesI As Integer
NBN = 0
SeriesI = 0
'Add value in tabNBN regarding to the number of different batch number
For r2 = 0 To r - 1 Step 1
checkNBN = False
For Each elementNBN In tabNBN
If elementNBN = tabReo(1, r2) Then
checkNBN = True
End If
Next elementNBN
If checkNBN = False Then
ReDim Preserve tabNBN(NBN)
tabNBN(NBN) = tabReo(1, r2)
NBN = NBN + 1
End If
Next r2
So I need something to add the series regarding of the number of different batch number and insert the value and the date there.
I'm a beginner with charts in VBA.
if my understanding of the objective is correct then congratulation for a good & challenging question. Assuming the objective is to create a single chart with multiple series representing each batch listed in the range. If assumed result is like the following
then may try the test code (obviously after modifying the range, sheet etc to requirement). The code used Dictionary object, so please add Tools-> Reference to "Microsoft Scripting Runtime". Though I am not fully satisfied with the code regarding some multiple looping etc (degrading the performance) but would work OK with normal data assuming 100/200 rows. I invite experts response for more efficient code in this regard
Option Explicit
Sub test3()
Dim Cht As Chart, ChartObj As ChartObject
Set ChartObj = ActiveSheet.ChartObjects.Add(Left:=10, Width:=550, Top:=10, Height:=325)
'Set ChartObj = ActiveSheet.ChartObjects("Chart 4")
Set Cht = ChartObj.Chart
Cht.ChartType = xlLine
Cht.HasTitle = True
Cht.ChartTitle.Text = "Humidite"
Dim Rw As Long, Dic As Dictionary, DataArr As Variant, OutArr() As Variant, BatchArr() As Variant, DateArr As Variant
Dim Rng As Range, SeriesNo As Long, Dmax As Date, Dmin As Date, dt As Date
Dim X As Long, i As Long, Xbatch As Variant, Batch As Variant
Dim Cnt As Long, Xval As Variant, PrvDt As Date, C As Range, DayCnt As Long
Dim firstAddress As String
Set Dic = CreateObject("Scripting.dictionary")
Set Rng = ThisWorkbook.ActiveSheet.Range("A2:A100") 'Modify to requireMent
DataArr = ThisWorkbook.ActiveSheet.Range("A2:C100") 'Modify to requireMent
SeriesNo = 0
'Create dictionary reference to unique Batch name from the list
For Rw = 1 To UBound(DataArr, 1)
Batch = DataArr(Rw, 2)
If Dic.Exists(Batch) = False Then
SeriesNo = SeriesNo + 1
Dic.Add Batch, SeriesNo
End If
Next
Dmax = Application.WorksheetFunction.Max(Range(Rng(1, 1), Rng(Rng.Rows.Count, 1)))
Dmin = Application.WorksheetFunction.Min(Range(Rng(1, 1), Rng(Rng.Rows.Count, 1)))
DayCnt = Dmax - Dmin + 1
ReDim BatchArr(1 To DayCnt)
ReDim DateArr(1 To DayCnt)
ReDim OutArr(1 To SeriesNo, 1 To DayCnt)
'Populate DateArr for dates
For X = 1 To DayCnt
DateArr(X) = Dmin + X - 1
Next
'Populate OutArr(Series,DayCnt) with existing Values, Non existing values are kept empty
For X = 1 To DayCnt
dt = DateArr(X)
With Rng
Set C = .Find(dt)
If Not C Is Nothing Then
firstAddress = C.Address
Do
OutArr(Dic(C.Offset(0, 1).Value), X) = C.Offset(0, 2).Value
'Debug.Print C.Value, C.Offset(0, 1).Value, C.Offset(0, 2).Value
Set C = .FindNext(C)
Loop While Not C Is Nothing And C.Address <> firstAddress
End If
End With
Next
With Cht
'delete If any automatically added series
For i = Cht.SeriesCollection.Count To 1 Step -1
.SeriesCollection(i).Delete
Next
'Create Series and Set Values & Xvalues from OutArr
Dim Srs As Series
For X = 1 To SeriesNo
Batch = Dic.Keys(X - 1)
For Cnt = 1 To DayCnt
BatchArr(Cnt) = OutArr(Dic(Batch), Cnt)
'If IsEmpty(BatchArr(Cnt)) = False Then Debug.Print X, Cnt, BatchArr(Cnt), DateArr(Cnt)
Next
Cht.SeriesCollection.NewSeries
Set Srs = Cht.SeriesCollection(X)
With Srs
.Values = BatchArr
.XValues = DateArr
.Name = Dic.Keys(X - 1)
End With
Next
Dim Cat As Axis
Set Cat = Cht.Axes(xlCategory)
Cat.TickLabels.NumberFormat = "dd/mm/yy"
End With
End Sub
Please comment if it suits your need
This code should create a table regarding to another table (the one with all different batch numbers and values) and the user selection and after build the chart with it.
I can send you the full file by mail if needed.
Thanks in advance.
Best regards
colin
Private Sub BtnGraph2_Click()
Dim tabBNumber() As String
Dim tabHumidite() As Double
Dim tabDate() As String
Dim tabReo() As String
Dim y As Integer
Dim h As Integer
Dim d As Integer
Dim a As Integer
Dim w As Integer
Dim w2 As Integer
Dim r As Integer
h = 0
y = 0
d = 0
w = 1
w2 = 1
r = 0
ReDim tabHumidite(h)
ReDim tabBNumber(y)
ReDim tabDate(d)
Range("tabReorganize[#data]") = ""
ListObjects("tabReorganize").Resize Range(Range("tabReorganize[#headers]").Address, Range("tabReorganize[#headers]").Offset(1).Address)
For i6 = ListBox1.ListCount - 1 To 0 Step -1
If ListBox1.Selected(i6) = True Then
ReDim Preserve tabBNumber(y)
tabBNumber(y) = ListBox1.List(i6)
y = y + 1
End If
Next i6
For Each delement In tabBNumber
For Each delement2 In Range("tabGraph[Date]")
If "0" & delement2.Offset(0, 2) = delement Or delement2.Offset(0, 2) = delement Then
ReDim Preserve tabDate(d)
tabDate(d) = delement2
d = d + 1
End If
Next delement2
Next delement
For Each Oelement In tabDate
Range("tabReorganize[Date]").Cells(w) = Format(Oelement, "mm/dd/yyyy")
w = w + 1
Next Oelement
If BtnHumidite = True Then
For Each element In tabBNumber
h = 0
a = 0
ReDim tabHumidite(h)
For Each Gelement In Range("tabGraph[Humidite]")
If "0" & Gelement.Offset(0, -1) = element Or Gelement.Offset(0, -1) = element Then
ReDim Preserve tabHumidite(h)
tabHumidite(h) = Gelement
h = h + 1
End If
Next Gelement
For Each O2element In tabHumidite
Range("tabReorganize[Humidite]").Cells(w2) = Format(O2element, "###0.00")
Range("tabReorganize[Batch Number]").Cells(w2) = Format(element, "00000000")
w2 = w2 + 1
Next O2element
Next element
End If
Range("tabReorganize").Sort Key1:=Range("tabReorganize[[#All],[Date]]"), Order1:=xlAscending, Header:=xlYes
For Each elementReo In Range("tabReorganize[Date]")
ReDim Preserve tabReo(2, r)
tabReo(0, r) = elementReo
tabReo(1, r) = 0 & elementReo.Offset(0, 1)
tabReo(2, r) = elementReo.Offset(0, 2)
r = r + 1
Next elementReo
'''' Chart part
Dim Cht As Chart, ChartObj As ChartObject
Set ChartObj = ActiveSheet.ChartObjects.Add(Left:=2979.75, Width:=550, Top:=358.5, Height:=325)
Set Cht = ChartObj.Chart
Cht.ChartType = xlLine
Cht.HasTitle = True
Cht.ChartTitle.Text = "Humidite"
Dim Rw As Long, Dic As Dictionary, DataArr As Variant, OutArr() As Variant, BatchArr() As Variant, DateArr As Variant
Dim Rng As Range, SeriesNo As Long, Dmax As Date, Dmin As Date, dt As Date
Dim X As Long, i As Long, Xbatch As Variant, Batch As Variant
Dim Cnt As Long, Xval As Variant, PrvDt As Date, C As Range, DayCnt As Long
Dim firstAddress As String
Set Dic = CreateObject("Scripting.dictionary")
Set Rng = ThisWorkbook.ActiveSheet.Range("AP13:AP42") 'Modify to requireMent
'Set Rng = ThisWorkbook.ActiveSheet.Range("tabReorganize[Date]")
DataArr = ThisWorkbook.ActiveSheet.Range("AP13:AR42") 'Modify to requireMent
'DataArr = ThisWorkbook.ActiveSheet.Range("tabReorganize[#data]")
SeriesNo = 0
'Create dictionary reference to unique Batch name from the list
For Rw = 1 To UBound(DataArr, 1)
Batch = DataArr(Rw, 2)
If Dic.Exists(Batch) = False Then
SeriesNo = SeriesNo + 1
Dic.Add Batch, SeriesNo
End If
Next
Dmax = Application.WorksheetFunction.max(Range(Rng(1, 1), Rng(Rng.Rows.Count, 1)))
Dmin = Application.WorksheetFunction.Min(Range(Rng(1, 1), Rng(Rng.Rows.Count, 1)))
DayCnt = Dmax - Dmin + 1
ReDim BatchArr(1 To DayCnt)
ReDim DateArr(1 To DayCnt)
ReDim OutArr(1 To SeriesNo, 1 To DayCnt)
'Populate DateArr for dates
For X = 1 To DayCnt
DateArr(X) = Dmin + X - 1
Next
'Populate OutArr(Series,DayCnt) with existing Values, Non existing values are kept empty
For X = 1 To DayCnt
dt = DateArr(X)
With Rng
Set C = .Find(dt)
If Not C Is Nothing Then
firstAddress = C.Address
Do
OutArr(Dic(C.Offset(0, 1).Value), X) = C.Offset(0, 2).Value
'Debug.Print C.Value, C.Offset(0, 1).Value, C.Offset(0, 2).Value
Set C = .FindNext(C)
Loop While Not C Is Nothing And C.Address <> firstAddress
End If
End With
Next
With Cht
'delete If any automatically added series
For i = Cht.SeriesCollection.Count To 1 Step -1
.SeriesCollection(i).Delete
Next
'Create Series and Set Values & Xvalues from OutArr
Dim Srs As Series
For X = 1 To SeriesNo
Batch = Dic.Keys(X - 1)
For Cnt = 1 To DayCnt
BatchArr(Cnt) = OutArr(Dic(Batch), Cnt)
'If IsEmpty(BatchArr(Cnt)) = False Then Debug.Print X, Cnt, BatchArr(Cnt), DateArr(Cnt)
Next
Cht.SeriesCollection.NewSeries
Set Srs = Cht.SeriesCollection(X)
With Srs
.Values = BatchArr
.XValues = DateArr
.Name = Dic.Keys(X - 1)
End With
Next
Dim Cat As Axis
Set Cat = Cht.Axes(xlCategory)
Cat.TickLabels.NumberFormat = "mm/dd/yy"
End With
I'm creating a code that will go through a list of numbers and interpolate a range of "new Xs" What I'm trying to do is instead of having to modify the code in order to loop through a different range of cells, I would like select the range of cells in the spreadsheet and then output the new data next to the existing data.
I was wondering if there was someway to index a selected range so I can use for my loops.
Private Sub Test_Click()
Dim rng As Integer, num As Integer
Dim xLower As Double, yLower As Double, xNew As Double
Dim xHigher As Double, yHigher As Double, yNew As Double
xNew = 0
For num = 1 To 28
xNew = xNew + 0.01
xLower = 0
yLower = 0
xHigher = 1.26
yHigher = 0
For rng = 2 To 108
If xNew - ActiveSheet.Cells(rng, 1).Value < xNew - xLower And ActiveSheet.Cells(rng, 1) < xNew Then
xLower = ActiveSheet.Cells(rng, 1).Value
yLower = ActiveSheet.Cells(rng, 3).Value
ElseIf xNew + ActiveSheet.Cells(rng, 1).Value < xNew + xHigher And ActiveSheet.Cells(rng, 1) > xNew Then
xHigher = ActiveSheet.Cells(rng, 1).Value
yHigher = ActiveSheet.Cells(rng, 3).Value
End If
Next rng
yNew = (xNew - xLower) / (xHigher - xLower) * (yHigher - yLower) + yLower
Cells(num, 7) = yNew
Cells(num, 6) = xNew
Next num
End Sub
Set the selection as a range to loop through, and determine the location of the upper left cell in the range, such that:
dim ulRow as long, ulCol as long, selrng as range
ulRow = selection.row
ulCol = selection.column
Set selrng = application.selection
You can then loop with that info, or output relative to that range, e.g.,
for each cl in selrng
if isempty(cl) then cells(ulRow,ulCol+1).value = "moo"
next cl
Edit1:
Adding in a way to find the last cell's row/col in case that's needed:
With selrng
lr = .row + .rows.count - 1
lc = .column + .columns.count - 1
end with
You can then loop like:
For i = ulRow to lr
if cells(i,lc).value <> 0 then cells(i,lc+1).value = "moo"
next i
I'm getting a type mismatch error while comparing a range value to "" or vbNullString. i read many similar q+a posts that deal with this issue.
The data is all numbers or "".
Sub vegetableCounting()
Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
Dim ws1Range As Excel.range, ws2Range As Excel.range, ws3Range As Excel.range, ws2Loop As Excel.range
Dim ws1Row As Long, ws1Col As Long, ws2Row As Long, ws2Col As Long
'
Dim rowCounter As Long, colCounter As Long, rowsMendo As Long
Dim mendoSum As Double
'
Set ws1 = Sheets("shareSchedule")
Set ws2 = Sheets("shareDistribution")
Set ws3 = Sheets("vegCount")
'***not yet set to the full ranges***
Set ws1Range = ws1.range("E7:H11") 'shareSchedule
Set ws2Range = ws2.range("D7:BB17") 'shareDistribution
Set ws3Range = ws3.range("D7:BB11") 'vegetableCount
'***not yet set to the full ranges***
rowsMendo = 0
rowCounter = 0
colCounter = 0
mendoSum = 0
For ws1Row = 0 To ws1Range.Rows.count Step 1
For ws1Col = 0 To ws1Range.Columns.count Step 1
If ws1Range.Offset(ws1Row, ws1Col).value <> "" Then
For Each ws2Loop In ws2Range '11rows*51cols = 561
ws2Row = ws2Row + rowCounter + rowsMendo
ws2Col = ws2Col + colCounter
If ws2Range.Offset(ws2Row, ws2Col).value = "" Then
Exit For
Else
If ws1Range.Offset(ws1Row, ws1Col).Interior.ColorIndex = 24 And _
ws2Range.Offset(ws2Row, ws2Col).Interior.ColorIndex = 24 Then 'a MENDO match
If rowCounter < 3 Then
mendoSum = mendoSum + ws1Range.Offset(ws1Row, ws1Col).value * ws2Range.Offset(ws2Col, ws2Row)
rowCounter = rowCounter + 1
ElseIf rowCounter = 3 Then
colCounter = colCounter + 1
rowCounter = 0
ElseIf colCounter = ws2Range.Columns.count + 1 And _
ws2Range.Offset(ws2Row, 1).Interior.ColorIndex = 24 And _
ws2Range.Offset(ws2Row + 4, 1).Interior.ColorIndex = 24 Then
colCounter = 0
rowsMendo = rowsMendo + 3
ElseIf colCounter = ws2Range.Columns.count + 1 And _
ws2Range.Offset(ws2Row, 1).Interior.ColorIndex = xlNone And _
ws2Range.Offset(ws2Row + 4, 1).Interior.ColorIndex = xlNone Then
colCounter = 0
rowsMendo = rowsMendo + 1
End If
ws3Range.Offset(ws1Row, ws2Col) = ws1Range.Offset(ws1Row, ws1Col).value * ws2Range.Offset(ws2Row, ws2Col).value
End If
End If
Next
End If
Next ws1Col
Next ws1Row
'for ws2
'Offset(0, 0), Offset(1, 0), Offset(2, 0), then
'Offset(0, 1), Offset(1, 1), Offset(2, 1), then
'Offset(0, 2), Offset(1, 2), Offset(2, 2), then
'etc
End Sub
i get the error on
If ws1Range.Offset(ws1Row, ws1Col).value <> "" Then
and ill prob get it again on
If ws2Range.Offset(ws2Row, ws2Col).value = "" Then
any thoughts? here are some images of the worksheets im trying to pull from
You could try CStr to convert the value to a String. Format could also be used as it handles Null whereas CStr would produce an error.
So either:
If CStr(ws1Range.Offset(ws1Row, ws1Col).value) <> "" Then
or
If Format(ws1Range.Offset(ws1Row, ws1Col).value) <> "" Then
I don't usually use the Offset function, but you can access the cells in a specified range by directly specifiying the row and column like an array.
EG: ws2Range(ws2Row, ws2Col).value
You have to start in 1 for your iterations though, you'll get an error when you start at 0.
when looking at the offset of a range, you get the entire range area, offset by your offset values.
e.g.
set a=sheets(1).range("A1:F40")
debug.print a.offset(1,1).address
giveas a result of
$B$2:$G$41
notice this is (A+1,1+1:F+1,40+1) and not a single cell
there are 2 options:
set your range to a single cell, and use offset to look at the area around that cell
use the range you have now, and use cells(x,y) to look in that range