I have a macro which imports weekly data into a new column and then runs a number of operations on it. I am having great difficulty with trying to sum the past ten weeks' data. Obviously formulae do not work since every week when I insert a new column, the formulae would not move to include the new column and drop the eleventh column.
The code I wrote to take this is:
Dim h As Range
Dim preCol As Long
With wsBOS.Rows(7)
Set h = .Find("Total", LookIn:=xlValues)
If Not h Is Nothing Then
preCol = h.Column - 1
End If
End With
For jCombo = 1 To 175
Dim siteCombo As String
siteCombo = ThisWorkbook.Sheets("Results Sheet").Cells(jCombo, 3)
If ((siteCombo = "Bone & Connective Tissue") Or (siteCombo = "Brain/CNS") Or (siteCombo = "Breast") Or (siteCombo = "GI") Or (siteCombo = "Gland/Lymphatic") Or (siteCombo = "GYN") _
Or (siteCombo = "Head & Neck") Or (siteCombo = "Leukemia Lymphoma") Or (siteCombo = "Lung") Or (siteCombo = "Gu") Or (siteCombo = "GU") Or (siteCombo = "Male") _
Or (siteCombo = "Metastasis Genital Organ") Or (siteCombo = "Other") Or (siteCombo = "Skin")) Then
ThisWorkbook.Sheets("Results Sheet").Cells(jCombo, preCol - 2).Value = Application.Sum(Range(Cells(jCombo, preCol - 11), (Cells(jCombo, preCol - 3))))
End If
Next jCombo
where jCombo increments rows downwards and preCol refers to the newly created column.
For whatever reason, this snippet is simply doing nothing when run. It does not throw any errors, it just leaves all 175 rows of preCol untouched. I am stumped and am turning to you for help.
If anyone has any ideas and wants to share them, I will be beyond appreciative. Thank you!!
preCol refers to Column OL.
I am trying to get the value to populate in column OJ.
Put this in Row 8 and copy down:
=SUM(INDEX(8:8,COLUMN()-1):INDEX(8:8,COLUMN()-10))
Since there are no column references it will always look at the last 10 columns in row 8. The 8:8 will change to the next row as it is dragged down.
This seems to be working for me
Option Explicit
Sub Dynamic_Duo()
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Sheet1")
Dim LC As Long, LR As Long, SumRange As String
LC = ws.Cells(6, ws.Columns.Count).End(xlToLeft).Offset.Column
LR = ws.Range("B" & ws.Rows.Count).End(xlUp).Offset(-2).Row
ws.Cells(6, LC + 1) = "10 Week"
ws.Cells(7, LC + 1) = "Total"
SumRange = ws.Range(ws.Cells(8, LC - 9), ws.Cells(8, LC)).Address(False, False)
ws.Range(ws.Cells(8, LC + 1), ws.Cells(LR, LC + 1)).Formula = "=Sum(" & SumRange & ")"
MsgBox "#Scott Craner's solution is better", vbCritical
End Sub
Related
Variance Table Sample I'm working on an Excel Macros (VBA) to look through every 3rd cell of each row in a data set and perform a copy paste action based on conditions (Please see the code at the bottom).
The source data is in a another worksheet (Variance). It has 1300+ IDs (rows) and 3 columns for each value component (col 1 - value 1, col 2 - value 2, and col 3 - the difference between the 2 values) and likewise there are 500+ columns.
My code basically looks through every third column (the difference column) of each row to find out if the value is a number, not equal to zero, and if it's not an error (there are errors in the source sheet). If yes, it copies the Emp ID, the column Name, and both the values into another worksheet called vertical analysis (one below the other).
The code works fine, but it takes 6 to 7 minutes for a data set with 1000+ rows and 500+ columns.
Can someone please tell me if there is a faster way to do this than to loop through each row?
Please let me know if you need more information. Thanks in advance.
Code:
Sub VerticalAnalysis()
Dim EmpID As Range
Dim i As Long
Dim cell As Range
Dim lastrow As Range
Dim LastCol As Long
Dim curRow As Long
Dim c As Long
Set lastrow = ThisWorkbook.Worksheets("Variance").Cells(Rows.Count, 2).End(xlUp)
Set EmpID = ThisWorkbook.Worksheets("Variance").Range("B4", lastrow)
LastCol = ThisWorkbook.Worksheets("Variance").Cells(3, Columns.Count).End(xlToLeft).Column
Application.ScreenUpdating = False
MsgBox "Depending on the size of the record, your excel will not respond for several minutes during Vertical Analysis. Please don't close the workbook", , "Note: Please Don't Close the Workbook"
Worksheets("Vertical").Select
Range("B3", "H" & Rows.Count).ClearContents
Range("B3", "H" & Rows.Count).ClearFormats
ThisWorkbook.Worksheets("Variance").Select
c = 1
For Each cell In EmpID
i = 2
Do Until i >= LastCol
cell.Offset(0, i).Select
If IsError(ActiveCell) Then
ElseIf ActiveCell <> "" Then
If IsNumeric(ActiveCell) = True Then
If ActiveCell <> 0 Then
cell.Copy
Worksheets("Vertical").Range("B" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
ActiveCell.Offset(-c, -2).Copy
Worksheets("Vertical").Range("C" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
ActiveCell.Offset(0, -2).Copy
Worksheets("Vertical").Range("D" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
ActiveCell.Offset(0, -1).Copy
Worksheets("Vertical").Range("E" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
End If
End If
End If
i = i + 4
Loop
c = c + 1
Next cell
ThisWorkbook.Worksheets("Vertical").Select
Range("B2").Select
MsgBox "Analysis complete " & vbCrLf & Worksheets("Vertical").Range("B" & Rows.Count).End(xlUp).Row - 2 & " Components have variations", , "Success!"
Application.ScreenUpdating = True
End Sub
You might try to use SQL. In order to learn how to use sql in EXCEL VBA, I suggest you to follow this tuto and to apply your learn on your macro. They will be faster =)
https://analystcave.com/excel-using-sql-in-vba-on-excel-data/
Better not to hit the sheet so many times.
Below is tested and should run in a few seconds, but you may need to tweak the column positions etc:
Sub VerticalAnalysis()
Const BLOCK_SIZE As Long = 30000
Dim lastrow As Long
Dim LastCol As Long
Dim c As Long, wsVar As Worksheet, wsVert As Worksheet, n As Long
Dim data, r As Long, empId, v, rwVert As Long, dataVert, i As Long
Set wsVar = ThisWorkbook.Worksheets("Variance")
Set wsVert = ThisWorkbook.Worksheets("Vertical")
lastrow = wsVar.Cells(Rows.Count, 2).End(xlUp).Row
LastCol = wsVar.Cells(3, Columns.Count).End(xlToLeft).Column
'get all the input data as an array (including headers)
data = wsVar.Range("A3", wsVar.Cells(lastrow, LastCol)).Value
'clear the output sheet and set up the "transfer" array
With wsVert.Range("B3", "H" & Rows.Count)
.ClearContents
.ClearFormats
End With
rwVert = 3 'first "vertical" result row
ReDim dataVert(1 To BLOCK_SIZE, 1 To 4) 'for collecting matches
i = 0
n = 0
For r = 2 To UBound(data, 1) 'loop rows of input array
empId = data(r, 2) 'colB ?
c = 7 'first "difference" column ?
Do While c <= UBound(data, 2)
v = data(r, c)
If Not IsError(v) Then
If IsNumeric(v) Then
If v > 0.7 Then
i = i + 1
n = n + 1
dataVert(i, 1) = empId
dataVert(i, 2) = data(1, c) 'header
dataVert(i, 3) = data(r, c + 2) 'value1
dataVert(i, 4) = data(r, c + 1) 'value2
'have we filled the temporary "transfer" array?
If i = BLOCK_SIZE Then
wsVert.Cells(rwVert, 2).Resize(BLOCK_SIZE, 4).Value = dataVert
i = 0
ReDim dataVert(1 To BLOCK_SIZE, 1 To 4)
rwVert = rwVert + BLOCK_SIZE
End If
End If
End If
End If
c = c + 4 'next difference
Loop
Next r
'add any remaining
If i > 0 Then wsVert.Cells(rwVert, 2).Resize(BLOCK_SIZE, 4).Value = dataVert
wsVert.Select
wsVert.Range("B2").Select
MsgBox "Analysis complete " & vbCrLf & n & " Components have variations", , "Success!"
End Sub
Need any help on how I can achieve as in the image below.
I want to combine multiple rows of the same person into one while transposing the column value of the person into a single row. I would like to achieve doing it preferable via VBA but if not then by formula.
Sorry I don't have anything to show. I already have the codes to generate a unique list for the names but I don't know how to transpose the data in the respective columns. I don't have any idea on how to approach this problem. Seeking any guidance or even ideas.
Public Sub extractUniques(rngSource As Range, rngTarget As Range)
Application.ScreenUpdating = False
rngSource.AdvancedFilter Action:=xlFilterCopy, _
copytorange:=rngTarget, Unique:=True
Application.ScreenUpdating = True
End Sub
Try this!
Sub specialTransfer()
Dim inp As Range, outp As Range, rng As Range, c As Range, data(), u, r, x, i, j
Set inp = [A1] 'Change this to the top left cell of your input
Set outp = [F1] 'Change this to the top left cell of your output
Set rng = Range(inp.Offset(1, 1), Cells(Rows.Count, 2).End(xlUp))
data = rng.Value
Set u = CreateObject("Scripting.Dictionary")
For r = 1 To UBound(data)
u(data(r, 1)) = Empty
Next r
x = u.Keys()
'Option to clear out everything past the outputcell
'Range(outp, Cells(Rows.Count, Columns.Count)).ClearContents
outp = "Name"
For i = 0 To u.Count - 1
j = 1
outp.Offset(i + 1) = x(i)
For Each c In rng
Range(outp.Offset(, j), outp.Offset(, j + 2)) = Array("Day", "Time out", "Time in")
If WorksheetFunction.CountA(c.Offset(, -1).Resize(, 4)) = 4 Then
If c = x(i) Then
outp.Offset(i + 1, j).Value = Format(Mid(c.Offset(, -1), 4, 10), "General Number")
outp.Offset(i + 1, j + 1).Value = Format(c.Offset(, 1), "h:mm AM/PM")
outp.Offset(i + 1, j + 2).Value = Format(c.Offset(, 2), "h:mm AM/PM")
j = j + 3
End If
End If
Next c
Next i
End Sub
Hoping to be able to achieve it via VBA but don't think that I can. It's not the exact result I was hoping for but it works. Did it using array formula below.
=IFERROR(INDEX("table data",MATCH(1,("criteria1 column"="criteria1")*("criteria2 column"="criteria2")*("criteria3 column"<>""),0), "criteria3 colNum"),"")
Ctrl + Shift + Enter
multiple row into one
I have a system which inputs a code to a cell on a spreadsheet. It does this by using a Vlookup to determine which date it is. If you look at the code below the nput is what does this Vlookup.
What I want it to do is move down a cell per amount the amount that will be in a combo box value called DayAmount. What would I need to enter for it to look at the next cell?
For example if the 5th of January is in A24 I want it to also enter the same code in the 6th and 7th of January which the Vlookup knows is A25 and A26.
Private Sub Submitplan_Click()
' This searches for the selected engineer
Dim EngineerFound As Range
Dim Front As Worksheet
Dim wb As Workbook
Dim area As Worksheet
Set wb = ThisWorkbook
Dim tabchange As String
Set Front = wb.Worksheets("Front")
x = Front.Cells(Front.Rows.Count, "F").End(xlUp).Row
With Front.Range("F8:F" & x)
Set EngineerFound = .Find(Engbox.Value, LookIn:=xlValues)
End With
EngRow = EngineerFound.Row
'This is the section which enters the data into the right date
tabchange = ("Area") & Front.Range("B8")
Set area = wb.Worksheets(tabchange)
y = WorksheetFunction.VLookup(CLng(CDate(Datebox.Value)), area.Range("A:B"), 2, 0)
nPut = WorksheetFunction.VLookup(Key, area.Range("A:B"), 2, 0) &
Hoursbox.Value
z = area.Range("C:C").Find(Engbox.Value).Row
If area.Cells(z, y).Value = " B/H" Then
area.Cells(z, y).Value = nPut & " " & "B/H"
ElseIf area.Cells(z, y).Value = " WK" Then
area.Cells(z, y).Value = nPut & " " & "WK"
Else: area.Cells(z, y).Value = nPut
End If
' If DayAmount <> "" Then
'End If
Call Update
Unload Me
End Sub
If I'm reading this correctly, you have a value in a combobox (will say DayAmount) which will be assigned until a that value is met.
Dim i as Long, j as Long, k as Long
i = ActiveCell.Row
j = DayAmount
k = 1
If j > 1 Then
Do until k = j-1
Cells(k+1,1).Value = Cells(i,1)>Value
k = i + k
Loop
End If
Or you could use a filldown, or .value match, and when you enter the line to the destination cell, you use:
Dim i as Long, j as Long
i = ActiveCell.Row
j = DayAmount
Range(Cells(i,1),Cells(i+j,1)).Value = "" 'input here
Note the arbitrary activecell and column 1 usage as i'm unsure exactly where this would be for you.
Regarding, specifically, the use of nPut, you can use offset to help, such as:
Range(nPut, nPut.Offset(DayAmount,0)) = WorksheetFunction.VLookup(Key, area.Range("A:B"), 2, 0) & Hoursbox.Value
Note that I haven't tested the latter and it's off the top of my head.
As the title says - This code will search Sheet1,Column I for a certain word; e.g "White" and paste all matches into the set row on sheet 2. White represents a martial arts white belt and will paste all student names who are listed as white belt into a set row number/page on sheet2, however i can only fit 30 names on a page and some months there are more than 30 white belts so i need it to paste the first 30 names into the set rows and the remainder in the next page which lets say for example is 5 rows down from the 30th white belt.
There are hundreds of students and 23 different belt levels which always change row numbers on sheet 1 so a fixed method would not work. Please help.
Sub ADULTClearAndPaste()
Dim lr As Long, lr2 As Long, r As Long
Set Sh1 = ThisWorkbook.Worksheets("ADULT members to cut & past")
Set Sh2 = ThisWorkbook.Worksheets("ADULT Sign On Sheet")
Sh1.Select
lr = Sh1.Cells(Rows.Count, "B").End(xlUp).Row
w = 7
For r = 2 To lr
If Range("I" & r).Value = "White" Then
Sh2.Cells(w, 5).Value = Sh1.Cells(r, 2).Value
Sh2.Cells(w, 6).Value = Sh1.Cells(r, 3).Value
w = w + 1
End If
Next r
py = 79
For r = 2 To lr
If Range("I" & r).Value = "Pro Yellow" Then
Sh2.Cells(py, 5).Value = Sh1.Cells(r, 2).Value
Sh2.Cells(py, 6).Value = Sh1.Cells(r, 3).Value
py = py + 1
End If
Next r
Sh2.Select
End Sub
There's a couple of problems it looks like you will encounter. You are defining w and py as integers but you said that you could have a large number of people in each category and I'm assuming those numbers will change so you could end up with a problem by specifying which row to begin with.
This will allow you to put in your 23 belt colors in as an Array (Changes the Belts(2) to Belts(23) and fill in the colors) and then it will format your second sheet according to how many you have in each color based on the first page.
I am assuming you have a header on the second sheet in the first six rows. You may need to update the Header variable to accurately reference that range, as this will insert a page break then copy that header repeatedly for as long as necessary:
Sub ADULTClearAndPaste()
Dim Belts(2) As String
Belts(1) = "White"
Belts(2) = "Pro Yellow"
Dim NewRow As Long
Dim RowCounter As Long
Dim Item As Range
Dim Header As Range
Dim Sht1 As Worksheet
Dim Sht2 As Worksheet
Set Sht1 = ThisWorkbook.Worksheets("ADULT members to cut & past")
Set Sht2 = ThisWorkbook.Worksheets("ADULT Sign On Sheet")
'Specify Header Range
Set Header = Sht2.Range("A1:F6")
NewRow = 7
For i = 1 To UBound(Belts)
'This creates a new header/page for the next belt color
If NewRow <> 7 Then
Sht2.Rows(NewRow).PageBreak = xlPageBreakManual
Sht2.Range(Sht2.Cells((NewRow), 1), Sht2.Cells((NewRow + 5), 6)).Value = Header.Value
NewRow = NewRow + 6
End If
'This will reference which color is being processed,
'I put it in there for reference but I figured you would update it
Sht2.Range("A" & NewRow).Value = Belts(i)
RowCounter = 0
For Each Item In Sht1.Range("I1:I" & Sht1.UsedRange.Rows.Count)
If Item.Value = Belts(i) Then
Sht2.Cells(NewRow, 5).Value = Item.Offset(0, 1).Value
Sht2.Cells(NewRow, 6).Value = Item.Offset(0, 2).Value
NewRow = NewRow + 1
RowCounter = RowCounter + 1
If RowCounter = 30 Then
'When you hit 30 lines the counter resets and a new header is added
Sht2.Rows(NewRow).PageBreak = xlPageBreakManual
Sht2.Range(Sht2.Cells((NewRow), 1), Sht2.Cells((NewRow + 5), 6)).Value = Header.Value
NewRow = NewRow + 6
RowCounter = 0
End If
End If
Next Item
Next i
Sht2.Select
End Sub
I am new to VBA and to this forum. I have a table with dates as the first column (x column) and 12 columns of data pertaining to the data (y values). I am trying to plot the data in a simple xlLine chart. Only few selected columns are to be plotted for y values. The columns are selected using a combo box at the top of the column. The number of rows are variable.
I am using this code but this is not working. Can someone kindly let me know what is wrong and fix it? Appreciate any help. Thanks in advance.
Sub drawchart1()
'
' drawchart1 Macro
'
'
Dim i As Integer
Dim j As Integer
Dim n As Integer
' finding the number of rows
j = Range("Charts!A1").Offset(Sheet1.Rows.Count - 1, 0).End(xlUp).Row
' selecting some range and adding a chart which is then modified.(not sure this is the correct method.)
Range("A10:C15").Select
ActiveSheet.Shapes.AddChart.Select
ActiveChart.ChartType = xlLine
i = 2
n = 2
' Cells (9,1) contains the value "Date". Defining the X Axis values
ActiveChart.SeriesCollection(1).Name = Sheets("Charts").Cells(9, 1).Value
ActiveChart.SeriesCollection(1).XValues = "=Charts!R10C1:R" & j & "C1"
Do While i < 14
' Cells(8,i) contain the results of combo box - true or false.
' Cells(9,i) contain the names of the series
If Cells(8, i).Value = True Then
ActiveChart.SeriesCollection(n).Name = Sheets("Charts").Cells(9, i).Value
ActiveChart.SeriesCollection(n).Values = "=Charts!R10C" & i & ":R" & j & "C" & i
n = n + 1
i = i + 1
Else
i = i + 1
End If
Loop
End Sub
Hi Again,
Since my columns would not exceed 14 (i.e. not large), I used the following "brute force" technique and it worked fine. I would still love to learn how to do it without using the "brute force" technique. Thanks in advance.
Sub drawchart()
Dim j As Integer
Dim Chartstring As String
j = Range("Charts!A1").Offset(Sheet1.Rows.Count - 1, 0).End(xlUp).Row
Chartstring = "A9:A" & j
If Cells(8, 2).Value = True Then
Chartstring = Chartstring & ", B9:B" & j
Else
Chartstring = Chartstring
End If
If Cells(8, 3).Value = True Then
Chartstring = Chartstring & ", C9:C" & j
Else
Chartstring = Chartstring
End If
' And similarly added code for each of the 14 columns
' And finally fed the chartstring into the "Source"
ActiveSheet.Shapes.AddChart.Select
ActiveChart.ChartType = xlLine
ActiveChart.SetSourceData Source:=Range(Chartstring)
End Sub
Probably you're not watching any more. Here's an alternative approach.
Sub DrawChart1()
Dim i As Long
Dim j As Long
Dim ws As Worksheet
Dim rCht As Range, rYVals As Range
Dim cht As Chart
' finding the number of rows
Set ws = Worksheets("Charts")
j = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
' start with X values (row 10 to j), include header row (row 9)
Set rCht = ws.Range(ws.Cells(9, 1), ws.Cells(j, 1))
' add column of Y values if row 8 of column is TRUE
For i = 2 To 14
If ws.Cells(8, i).Value Then
Set rYVals = ws.Range(ws.Cells(9, i), ws.Cells(j, i))
Set rCht = Union(rCht, rYVals)
End If
Next
' if we've had any Y values, insert chart, using range we've built up
If Not rYVals Is Nothing Then
Set cht = ws.Shapes.AddChart(xlLine).Chart
cht.SetSourceData Source:=rCht, PlotBy:=xlColumns
End If
End Sub