I am trying to copy data from one sheet as long as the meet the twp below criteria. However, not all the data is being transferred. Any thing stand out to anyone as wrong in my code?
Private Sub FIlist()
Dim LastRow As Long, fgLastRow As Long
Dim c As Integer
LastRow = ActiveWorkbook.Sheets("DaysReport").Range("A1000000").End(xlUp).Row
LastRow = LastRow + 1
Call StartCode
With ActiveWorkbook
For c = 1 To LastRow
If .Sheets("DaysReport").Range("B1").Offset(c - 1, 0) = "ACCEPT" And .Sheets("DaysReport").Range("C1").Offset(c - 1, 0) = "ST" Then
fgLastRow = ActiveWorkbook.Sheets("FG LIST").Range("A1000000").End(xlUp).Row
fgLastRow = fgLastRow + 1
.Sheets("FG LIST").Range("A" & fgLastRow) = .Sheets("DaysReport").Range("A2").Offset(c - 1, 0)
End If
c = c + 1
Next c
End With
Call EndCode
End Sub
The first thing that jumps out is that c should be Long as well.
The use of ActiveWorkbook may be a deliberate design choice - but if it always runs from this workbook, then use ThisWorkbook. Your user could change the workbook or active window at any time, thus causing chaos and mayhem (or at least unknown or undefined results).
Don't use Call - this is now deprecated. Not a show stopper, but still a bad habit.
Watch your index offsets, they can be confusing. Instead of c-1 all the time, just set your start parameters earlier. This means that we remove a +1 in a couple of spots as well!
Now that I tidied the code up - I saw the biggie. And the cause of your problems. I have left it commented in the code below. You are in a loop, and you also increment c (c = c + 1). This means that you skip every second row. If you really want to skip every second row then use For c = 0 To LastRow Step 2 because it is clearer code and your intention is obvious.
Private Sub FIlist()
Dim LastRow As Long, fgLastRow As Long
Dim c As Integer
StartCode
With ThisWorkbook.Sheets("DaysReport")
LastRow = .Range("A1000000").End(xlUp).Row
For c = 0 To LastRow
If .Range("B1").Offset(c, 0) = "ACCEPT" And .Range("C1").Offset(c, 0) = "ST" Then
fgLastRow = ThisWorkbook.Sheets("FG LIST").Range("A1000000").End(xlUp).Row + 1
ThisWorkbook.Sheets("FG LIST").Range("A" & fgLastRow) = .Range("A2").Offset(c, 0)
End If
'c = c + 1
Next c
End With
EndCode
End Sub
You must get rid of that
c = c + 1
Which is making your loop variable update by steps of two !
Furthermore you may want to adopt the following refactoring of your code:
Private Sub FIlist()
Dim cell As Range
Dim fgSht As Worksheet
Set fgSht = ActiveWorkbook.Sheets("FG LIST")
StartCode
With ActiveWorkbook.Sheets("DaysReport")
For Each cell In .Range("A1", .Cells(.Rows.Count, 1).End(xlUp))
If cell.Offset(,1).Value = "ACCEPT" And cell.Offset(,2).Value = "ST" Then fgSht.Cells(fgSht.Rows.Count, 1).End(xlUp).Offset(1).Value = cell.Offset(1).Value
Next
End With
EndCode
End Sub
Please note that I wrote:
If cell.Offset(,1).Value = "ACCEPT" And cell.Offset(,2).Value = "ST" Then fgSht.Cells(fgSht.Rows.Count, 1).End(xlUp).Offset(1).Value = cell.Offset(1).Value
To cope with your code that copied the value in column A one row below the current loop row
Should you actually need to copy the value in column A current row, then just remove that last .Offset(1)
Related
Just started a new job. I'm automating a month-end report and I'm new at VBA. Been googling most of my issues with success, but I've finally run into a wall. In essence I'm downloading some data from SAP and from there I need to build a report.
My question is: How to do a sumif function using loops in VBA?
Data pull:
Sheet1 contains a product code and purchase amounts (columns A & B) respectively. One product code can have several purchases (several rows with the same product code).
Steps so far:
I arranged the data sheet1 to be in ascending order.
Copied unique values for the product codes onto another sheet (sheet2). So Sheet2 has a list of all the products (in ascending order).
I want to get the sum of all purchases in sheet2 column B (per product code). I know how to do this using formulas, but I need to automate this as much as possible. (+ I'm genuinely interested in figuring this out)
This is what I did in VBA so far:
Sub Macro_test()
Dim tb As Worksheet
Dim tb2 As Worksheet
Dim x As Integer
Dim y As Integer
Dim lrow As Long
Set tb = Sheets("sheet1")
Set tb2 = Sheets("sheet2")
lrow = tb.Cells(Rows.Count, "A").End(xlUp).Row
For x = 2 To lrow
For y = 2 To lrow
If tb2.Cells(x, 1).Value = tb.Cells(y, 1).Value Then
tb2.Cells(x, 2).Value = tb.Cells(y, 2).Value
End If
Next y
Next x
End Sub
If i'm not mistaken, for each product_code in sheet2 col A, I'm looping through all the product codes in sheet1 and getting back the LAST value it finds, instead of the sum of all values... I understand why it doesn't work, I just don't know how to fix it.
Any help would be much appreciated. Thanks!
This statement overwrites the value of tb2.Cells(x, 2).Value at each iteration:
tb2.Cells(x, 2).Value = tb.Cells(y, 2).Value
Instead, I think you need to keep adding to it:
tb2.Cells(x, 2).Value = tb2.Cells(x, 2).Value + tb.Cells(y, 2).Value
But I don't like the looks of your double-loop which uses only one lrow variable to represent the "last row" on the two different worksheets, that could be causing some issues.
Or, in your loop do something like this which I think will avoid the duplicate sum. Still, assumes the second worksheet doesn't initially have any value in
' Base our lRow on Sheet2, we don't care how many rows in Sheet1.
lrow = tb2.Cells(tb2.Rows.Count, 1).End(xlUp).Row
Dim cl as Range
Set cl = tb.Cells(2,1) 'Our initial cell value / ID
For x = 2 to lRow '## Look the rows on Sheet 2
'## Check if the cell on Sheet1 == cell on Sheet2
While cl.Value = tb2.Cells(x,1).Value
'## Add cl.Value t- the tb2 cell:
tb2.Cells(x, 2).Value = tb2.Cells(x, 2).Value + cl.Offset(0,1).Value
Set cl = cl.Offset(1) '## Reassign to the next Row
Wend
Next
But it would be better to omit the double-loop and simply use VBA to do 1 of the following:
1. Insert The Formula:
(See Scott Holtzman's answer).
This approach is better for lots of reasons, not the least of which is that the WorksheetFunction is optimized already, so it should arguably perform better though on a small dataset the difference in runtime will be negligible. The other reason is that it's stupid to reinvent the wheel unless you have a very good justification for doing so, so in this case, why write your own version of code that accomplishes what the built-in SumIf already does and is specifically designed to do?
This approach is also ideal if the reference data may change, as the cell formulas will automatically recalculate based on the data in Sheet1.
2. Evaluate the formula & replace with values only:
If you prefer not to retain the formula, then a simple Value assignment can remove the formula but retain the results:
With .Range(.Range("B2"), .Range("A2").End(xlDown).Offset(, 1))
.FormulaR1C1 = "=SUMIF(Sheet1!C[-1]:C[-1],RC[-1],Sheet1!C:C)"
.Value = .Value 'This line gets rid of the formula but retains the values
End With
Use this approach if you will be removing Sheet1, as removing the referents will break the formula on Sheet2, or if you otherwise want the Sheet2 to be a "snapshot" instead of a dynamic summation.
If you really need this automated, take advantage of VBA to place the formula for you. It's very quick and easy using R1C1 notation.
Complete code (tested):
Dim tb As Worksheet
Dim tb2 As Worksheet
Set tb = Sheets("sheet1")
Set tb2 = Sheets("sheet2")
Dim lrow As Long
lrow = tb.Cells(tb.Rows.Count, 1).End(xlUp).Row
tb.Range("A2:A" & lrow).Copy tb2.Range("A2")
With tb2
.Range("A2").CurrentRegion.RemoveDuplicates 1
With .Range(.Range("B2"), .Range("A2").End(xlDown).Offset(, 1))
.FormulaR1C1 = "=SUMIF(Sheet1!C[-1]:C[-1],RC[-1],Sheet1!C:C)"
End With
End With
Note that with R1C1 notation the C and R are not referring to column or row letters . Rather they are the column and row offsets from the place where the formula is stored on the specific worksheet. In this case Sheet!C[-1] refers to the entire A column of sheet one, since the formula is entered into column B of sheet 2.
I wrote a neat little algorithm (if you can call it that) that does what you want them spits out grouped by totals into another sheet. Basically it loops through the first section to get unique names/labels and stores them into an array. Then it iterates through that array and adds up values if the current iteration matches what the current iteration of the nested loop position.
Private Sub that()
Dim this As Variant
Dim that(9, 1) As String
Dim rowC As Long
Dim colC As Long
this = ThisWorkbook.Sheets("Sheet4").UsedRange
rowC = ThisWorkbook.Sheets("Sheet4").UsedRange.Rows.Count
colC = ThisWorkbook.Sheets("Sheet4").UsedRange.Columns.Count
Dim thisname As String
Dim i As Long
Dim y As Long
Dim x As Long
For i = LBound(this, 1) To UBound(this, 1)
thisname = this(i, 1)
For x = LBound(that, 1) To UBound(that, 1)
If thisname = that(x, 0) Then
Exit For
ElseIf thisname <> that(x, 0) And that(x, 0) = vbNullString Then
that(x, 0) = thisname
Exit For
End If
Next x
Next i
For i = LBound(that, 1) To UBound(that, 1)
thisname = that(i, 0)
For j = LBound(this, 1) To UBound(this, 1)
If this(j, 1) = thisname Then
thisvalue = thisvalue + this(j, 2)
End If
Next j
that(i, 1) = thisvalue
thisvalue = 0
Next i
ThisWorkbook.Sheets("sheet5").Range(ThisWorkbook.Sheets("Sheet5").Cells(1, 1), ThisWorkbook.Sheets("Sheet5").Cells(rowC, colC)).Value2 = that
End Sub
Yay arrays
What the case is:
So I got a "results sample" in excel format that needs filtering and reshaping to look nice. It is a result that will be not identical all the time but it follows similar rules. I have to filter it further and make it a little more tidy. I have figured out the filtering part, but I am not sure how to sort the remaining data, in a tidy way.
What the situation is:
There are six columns involved.
Notice: Real deal is not THAT simple, but what I need can be demonstrated using such a simple example and then I can manage more complex stuff myself I suppose.
For our example we use columns from B to G
The data are set as pairs of a "title" and a value.
For instance, if you look the first example picture I provide, The first detais the pair B3 and C3.
As you can see, looking at the same picture, D3 and E3 is an empty pair.
Same goes for D4 - E4 and F4 - G4 and so on until a last one at B11 - C11.
Starting data example:
[
What I want to achieve:
I would like, using Visual Basic for Applications, to sort the data, starting from let's say for our example B3 (see second picture) and fill three SETS of two columns, (BC, DE, FG) if there are no data inside those cells.
Notice: If a cell like D3 is null then SURELY E3 will be null too so there can be just only one check. I mean we can check either value columns or title columns.
Notice2: The B,D,F or C,E,G columns DON'T have to be sorted. I just want all the not-null values of B,D,F and their respective values from C,E,G gathered together neat so printing will not need 30 pages but just a few (too many spaces between is causing it and I try to automate the cleanup)
Here's something to start with. The first double loop populates a VBA Collection with Range variables that refer to the Cells that contain the titles.
The associated values are obtained by using an offset. The middle double loop performs a bubble sort on the latter (highly inefficient - you might want to replace it with something else). The next if statement creates a 2nd sheet if it doesn't exist on which to write out the results (last loop).
Option Explicit
Sub GatherData()
Dim lastRow As Integer, lastCol As Integer
Dim r As Integer, c As Integer
Dim vals As Collection
Set vals = New Collection
With Sheets(1)
lastCol = .UsedRange.Columns(.UsedRange.Columns.Count).Column
lastRow = .UsedRange.Rows(.UsedRange.Rows.Count).row
For c = 1 To lastCol Step 2
For r = 1 To lastRow
If (Trim(Cells(r, c).Value) <> "") Then
vals.Add .Cells(r, c)
End If
Next
Next
End With
' Bubble Sort
Dim i As Integer, j As Integer
Dim vTemp As Range
For i = 1 To vals.Count - 1
For j = i + 1 To vals.Count
If vals(i).Value > vals(j).Value Then
Set vTemp = vals(j)
vals.Remove j
vals.Add vTemp, vTemp, i
End If
Next j
Next i
Dim sht2 As Worksheet
If ThisWorkbook.Worksheets.Count = 1 Then
Set sht2 = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(1))
Else
Set sht2 = Worksheets(2)
End If
With sht2
r = 3
c = 2
For i = 1 To vals.Count
.Cells(r, c).Value = vals(i).Value
.Cells(r, c + 1).Value = vals(i).Offset(, 1).Value
c = c + 2
If c = 8 Then
r = r + 1
c = 2
End If
Next
End With
End Sub
Here is a method using the Dictionary object. I use early binding which requires setting a reference to Microsoft Scripting Runtime. If you are going to be distributing this, you might want to convert this to late-binding.
We assume that your data is properly formed as you show it above. In other words, all the titles are in even numbered columns; and the results are in the adjacent cell.
We create the dictionary using the Title as the Key, and the adjacent cell value for the Dictionary item.
We collect the information
Transfer the Keys to a VBA array and sort alphabetically
create a "Results Array" and populate it in order
write the results to a worksheet.
I will leave formatting and header generation to you.
By the way, there is a constant in the code for the number of Title/Value pair columns. I have set it to 3, but you can vary that.
Enjoy
Option Explicit
Option Compare Text 'If you want the sorting to be case INsensitive
'set reference to Microsoft Scripting Runtime
Sub TidyData()
'Assume Titles are in even numbered columns
'Assume want ColPairs pairs of columns for output
'Use dictionary with Title as key, and Value as the item
Dim dctTidy As Dictionary
Dim arrKeys As Variant
Dim wsSrc As Worksheet, wsRes As Worksheet, rRes As Range
Dim vSrc As Variant, vRes As Variant
Dim LastRow As Long, LastCol As Long
Dim I As Long, J As Long, K As Long, L As Long
Dim V As Variant
'in Results
Const ColPairs As Long = 3
'Set Source and results worksheet and range
Set wsSrc = Worksheets("sheet1")
Set wsRes = Worksheets("sheet2")
Set rRes = wsRes.Cells(1, 2)
'Read source data into variant array
With wsSrc.Cells
LastRow = .Find(what:="*", after:=.Item(1, 1), _
LookIn:=xlValues, searchorder:=xlByRows, searchdirection:=xlPrevious).Row
LastCol = .Find(what:="*", after:=.Item(1, 1), _
LookIn:=xlValues, searchorder:=xlByColumns, searchdirection:=xlPrevious).Column
vSrc = .Range(.Cells(1, 1), .Cells(LastRow, LastCol))
End With
'Collect the data into a dictionary
Set dctTidy = New Dictionary
For I = 1 To UBound(vSrc, 1)
For J = 2 To UBound(vSrc, 2) Step 2
If vSrc(I, J) <> "" Then _
dctTidy.Add Key:=vSrc(I, J), Item:=vSrc(I, J + 1)
Next J
Next I
'For this purpose, we can do a simple sort on the dictionary keys,
' and then create our results array in the sorted order.
arrKeys = dctTidy.Keys
Quick_Sort arrKeys, LBound(arrKeys), UBound(arrKeys)
'Create results array
ReDim vRes(1 To WorksheetFunction.RoundUp(dctTidy.Count / ColPairs, 0), 1 To ColPairs * 2)
I = 0
J = 0
For Each V In arrKeys
K = Int(I / ColPairs) + 1
L = (J Mod ColPairs) * 2 + 1
vRes(K, L) = V
vRes(K, L + 1) = dctTidy(V)
I = I + 1
J = J + 1
Next V
'write the results
Set rRes = rRes.Resize(UBound(vRes, 1), UBound(vRes, 2))
With rRes
.Worksheet.Cells.Clear
.Value = vRes
.HorizontalAlignment = xlCenter
End With
End Sub
Sub Quick_Sort(ByRef SortArray As Variant, ByVal first As Long, ByVal last As Long)
Dim Low As Long, High As Long
Dim Temp As Variant, List_Separator As Variant
Low = first
High = last
List_Separator = SortArray((first + last) / 2)
Do
Do While (SortArray(Low) < List_Separator)
Low = Low + 1
Loop
Do While (SortArray(High) > List_Separator)
High = High - 1
Loop
If (Low <= High) Then
Temp = SortArray(Low)
SortArray(Low) = SortArray(High)
SortArray(High) = Temp
Low = Low + 1
High = High - 1
End If
Loop While (Low <= High)
If (first < High) Then Quick_Sort SortArray, first, High
If (Low < last) Then Quick_Sort SortArray, Low, last
End Sub
Assuming we got all variables set and initialized properly, in this example:
Sheets("sheetname").Select ' because stupid things can happen...
For i = 3 To 13
Let newrangeT = "B" & i '
Let newrangeV = "C" & i '
If Sheets("sheetname").Range(newrangeV) <> "" Then
values(Position) = Sheets("sheetname").Range(newrangeV)
titles(Position) = Sheets("sheetname").Range(newrangeT)
Position = Position + 1
Else
' Don't do anything if the fields are null
End If
Next i
Sheets("sheetname").Range("B1:G13").Clear
' We then get each data from the arrays with a For loop.
' We set a columnset variable to 1.
' We set a currentrow variable to 3.
' If columnset is 1 data will enter in B and C and columnset = columnset +1
' Then if columnset is 2 we set data to DE and columnset = columnset +1
' But if columnset is 2we set data to FG and columnset = 1 and currentrow = currentrow +1
' Iterating the arrays will result in a neat setting of the data, but it will add zeros for all the nulls. Thus we need an If statement that will exclude that values checking the TITLE array (that should contain a title instead). if the value is not 0 then... we run what I describe, otherwise we do nothing.
Putting the data in the array is half of the trick.
Then we clear the area.
We set two string variables to declare ranges (actually cell reference) for every cell iterated in the loop. Here I demonstrated only for column set B,C
but we have to do the same for the rest of the columns.
The If statement here checks for null. You might have different needs, so changing the if statement changes the filtering. Here I check if the cells are not null. If the cells of column C contain data, put those data in values array and the respective B data on titles array but where? Position starts as 1 and we then iterate it +1 each time it adds something.
You can set data from an array using this command:
' current_row is set to the first row of the spreadsheet we wanna fill.
Sheets("sheetname").Select ' because stupid things can happen...
newrangeV = "C" & current_row
Sheets("sheetname").Range(newrangeV) = values(j)
The rest is just putting things together.
In any case, I wanna thank both of the people involved in this question, because I might didn't got the solution, but I got an idea of how to do other stuff, like accidentally learning something new. Cheers.
I am trying to get a For loop which copies an entire row from worksheet 1 to worksheet 3 if the cell in column C in ws1 and column AT in ws2 matches. I have two issues:
1. It seems to be stuck in the For i = xxxxx loop and does not move to the next k (only copies one line 25 times)
2. When I use it on a sheet that has 100,000 rows for worksheet 1 and 15,000 rows on worksheet 2, excel just crashes. Is there a way to manage this?
Sub CopyBetweenWorksheets()
Application.ScreenUpdating = False
Dim i As Long, k As Long, ws1 As Worksheet, ws2 As Worksheet, myVar As String, myVar2 As String
Set ws1 = Worksheets("BOM")
Set ws2 = Worksheets("APT")
Set ws3 = Worksheets("Combined")
'get the last row for w2 and w1
ii = ws1.Cells.SpecialCells(xlCellTypeLastCell).row
kk = ws2.Cells.SpecialCells(xlCellTypeLastCell).row
For k = 2 To kk
myVar = ws2.Cells(k, 46)
For i = 688 To ii '688 To ii
myVar2 = ws1.Cells(i, 3)
If myVar2 = myVar Then
ws3.Rows(k).EntireRow.Value = ws1.Rows(i).EntireRow.Value 'copy entire row
Exit For
End If
Next i
Next k
End Sub
Your code is fine (not mentioning the missing Application.ScreenUpdating = True), but it will hang on large number of rows and columns because of the amount of interations with the application (Excel in this case).
Each time you request a value from a single cell from Excel, your code will hang for about 4 secounds per 1 million requests. From an entire row it will hang for 4 secounds per 4000 requests. If you try writing a single cell, your code will hang for 4 secounds per 175000 requests, and writing an entire row will hang your code for 4 secounds per 300 requests.
This way, only if you try parsing 15.000 rows of data from one sheet to another, your code will hang for about 3,3 minutes.. not to mention all read requests..
So, always keep the amount of interactions with any application from vba to a minimum, even if you have to create a much bigger code.
Here is what your code should look like if you want to handle a lot of data:
Sub CopyBetweenWorksheets2()
Dim aAPT, aBOM, aCombined As Variant
Dim lLastRow As Long, lLastColumn As Long
Dim i As Long, j As Long
Const APTColRef = 3
Const BOMColRef = 46
Const MAXCol = 200
'Speed up VBA in Excel
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
'Get the last row and column to use with the combined sheet
lLastRow = WorksheetFunction.Min(APT.Cells.SpecialCells(xlCellTypeLastCell).Row, BOM.Cells.SpecialCells(xlCellTypeLastCell).Row)
lLastColumn = WorksheetFunction.Min(MAXCol, WorksheetFunction.Max(APT.Cells.SpecialCells(xlCellTypeLastCell).Column, BOM.Cells.SpecialCells(xlCellTypeLastCell).Column))
'Parse all values to an array, reducing interactions with the application
aAPT = Range(APT.Cells(1), APT.Cells(lLastRow, lLastColumn))
aBOM = Range(BOM.Cells(1), BOM.Cells(lLastRow, lLastColumn))
'Creates a temporary array with the values to parse to the destination sheet
ReDim aCombined(1 To lLastRow, 1 To lLastColumn)
'Loop trough values and parse the row value if true
For i = 1 To lLastRow
If aAPT(i, APTColRef) = aBOM(i, BOMColRef) Then
For j = 1 To lLastColumn
aCombined(i, j) = aAPT(i, j)
Next
End If
Next
'Parse values from the destination array to the combined sheet
Combined.Range(Combined.Cells(1), Combined.Cells(lLastRow, lLastColumn)) = aCombined
'Disable tweaks
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationManual
End Sub
!! I named the sheets objects in the VBA itself, so you don't have to declare a new variable and you also won't have any problems if you rename them later. So, insted of sheets("APT"), I just used APT (you will have to rename it too if you want the code to work) !!
Plus, here is my speed code I wrote for speed testing my codes. I always keep it at hand, and use it in almost every function i write
Sub Speed()
Dim i As Long
Dim dSec As Double
Dim Timer0#
Dim TimerS#
Dim TimerA#
Dim TimerB#
dSec = 4 ''Target time in secounds''
i = 1
WP1:
Timer0 = Timer
For n = 1 To i
SpeedTestA
Next
TimerA = Timer
For n = 1 To i
SpeedTestB
Next
TimerB = Timer
If TimerB - Timer0 < dSec Then
If TimerB - Timer0 <> 0 Then
i = CLng(i * (dSec * 2 / (TimerB - Timer0)))
GoTo WP1
Else
i = i * 100
GoTo WP1
End If
End If
MsgBox "Código A: " & TimerA - Timer0 & vbNewLine & "Código B: " & TimerB - TimerA & vbNewLine & "Iterações: " & i
End Sub
Sub SpeedTestA() 'Fist Code
End Sub
Sub SpeedTestB() 'Secound Code
End Sub
I have a Backend raw output data set, which consists of multiple columns with some of them being empty except of the header.
I would like to transfer this data into another worksheet, let's call it Backend - processed. In this worksheet, I would prepare a header row, which consists of some of the headers included in the original data set. There won't be any new headers in the processed worksheet (so basically headers(processed) is a subset of headers(raw output)).
Once, I used to solve this problem with a function (Index & Match), but with growing raw data sets, this became suboptimal from a performance perspective.
Since then, I've been reading up on VBA codes and this is what I came up with until now:
Sub test()
Dim r As Range, c As Range, msg As String
With Sheets("Backend - raw").Range("4:4").CurrentRegion
For Each r In Sheets("Backend - processed").Range("b7:t7")
Set c = .Rows(1).Find(r.Value, , , xlWhole, , 0)
If Not c Is Nothing Then
.Columns(c.Column).Copy
r.PasteSpecial xlPasteValues
Else
msg = msg & vbLf & r.Value
End If
Next
Application.CutCopyMode = False
End With
End Sub
The Range 4:4 is where the headers of the original raw data output are found. Range b7:t7 is where the headers of the processed data table are found.
Being a total beginner at VBA, I'm quite happy that it works, but still think that there is a huge margin for improvement:
1) It's still pretty slow, taking about 10 seconds to complete 40x500 arrays.
2) I don't know how to make it stop looking for the next header, if the last header was blank (end of range b7:t7)
3) I'm very much open to new/better approaches to tackle this issue.
Searching, copying and pasting can be quite time consuming affairs. You'd probably be better off reading the headers just once into some kind of stored list (a Collection would work well for you because it could store the column number as its value and the header text as its key.
Given that you are only copying and pasting values (ie you don't need to pass cell formatting into your processed sheet) then reading the values into an array and then writing that array to the sheet will be quicker.
The code below is an example of that, but I'm sure with more thought it could be made even quicker (for example by discarding a header from the collection once it's been used, or not having to find the last row number for every individual column).
Dim rawSht As Worksheet
Dim procSht As Worksheet
Dim headers As Collection
Dim c As Integer
Dim v As Variant
Set rawSht = ThisWorkbook.Worksheets("Backend - raw")
Set procSht = ThisWorkbook.Worksheets("Backend - processed")
Set headers = New Collection
For c = 1 To rawSht.Cells(4, Columns.Count).End(xlToLeft).Column
headers.Add c, rawSht.Cells(4, c).Text
Next
For c = 2 To 20
rawCol = headers(procSht.Cells(7, c).Text)
v = rawSht.Range(rawSht.Cells(5, rawCol), rawSht.Cells(Rows.Count, rawCol).End(xlUp)).Value2
procSht.Cells(8, c).Resize(UBound(v, 1)).Value = v
Next
This is using arrays (40 cols x 1000 rows in 0.03125 sec)
Option Explicit
Sub testArr()
Const HDR1 As Long = 4 'header row on sheet 1
Const HDR2 As Long = 7 'header row on sheet 2
Dim ws1 As Worksheet, ur1 As Range, vr1 As Variant, c1 As Long, c2 As Long, r As Long
Dim ws2 As Worksheet, ur2 As Range, vr2 As Variant, msg As String, t As Double
t = Timer
Set ws1 = Worksheets("Backend - raw")
Set ws2 = Worksheets("Backend - processed")
Set ur1 = ws1.UsedRange
Set ur2 = ws2.UsedRange.Rows(ws2.UsedRange.Row - HDR2 + 1)
Set ur2 = ur2.Resize(ur1.Row + ur1.Rows.Count - HDR1 + 1)
vr1 = ur1 'copy from Range to array
vr2 = ur2
For c1 = 1 To UBound(vr1, 2)
For c2 = 1 To UBound(vr2, 2)
If vr1(1, c1) = vr2(1, c2) Then
For r = 2 To UBound(vr1, 1)
vr2(r, c2) = vr1(r, c1)
Next
Exit For
Else
msg = msg & vbLf & vr1(HDR1, c1)
End If
Next
Next
ur2 = vr2 'copy from array back to Range
Debug.Print "testArr duration: " & Timer - t & " sec"
End Sub
Here is the code below:
Public n as Long ' <--above sub procedure
With Sheets("Sheet1").Range("A6").Offset(n, 0)
If n = 0 Then
.Value = 1
Else
.Value = .Parent.Range(.Address).Offset(-1, 0) + 1
End If
n = n + 1
End With
(See pic below) If I delete 4 then click command button again it just reset back to 1. I want to make it static so even I deleted the last value of row it still continue increment from the last value.
Store number
1
2
3
4
Try this:
Sub Test()
Dim trow As Long
With Sheets("Sheet1") '~~> change to suit
trow = .Range("A:A").Find(vbNullString, [A5]).Row
With .Range("A" & trow)
If trow = 6 Then .Value = 1 _
Else .Value = .Offset(-1, 0).Value + 1
End With
End With
End Sub
Above code finds the first blank cells. If it is A6 it assigns a value of 1.
Otherwise it assigns previous cell value plus 1. Is this what you're trying?
Edit1: Explanation
trow = .Range("A:A").Find(vbNullString, [A5]).Row
This finds the first empty row in Column A starting A5.
[A5] is used to return Range("A5") object. So it can also be written as:
trow = .Range("A:A").Find(vbNullString, .Range("A5")).Row
We used a VBA vbNullString constant as What argument in Range Object Find Method.
Find Method returns a Range Object so above can be written also like this:
Sub Test()
Dim r As Range
With Sheets("Sheet1") '~~> change to suit
Set r = .Range("A:A").Find(vbNullString, [A5])
With r
If .Row = 6 Then .Value = 1 _
Else .Value = .Offset(-1, 0).Value + 1
End With
End With
End Sub
What your asking for, a button with memory doesn't sound neatly solvable using just VBA.
You could potentially have a list on a hidden sheet that gets a value added to it each time the commandButton is pressed and it writes the max of the list values back to the target cell?
Alternatively you could investigate using a scrollbar from the form control section of the developer tab with a link to your target cell. I often use this technique for interactive sheets.
Named Range Method
Public sub btnPress
dim val as long
val = Range("PreviousCellValue")
set Range("PreviousCellValue") = val+1
Sheets("Sheet1").Range("A6").Offset(n, 0).value = Range("PreviousCellValue")
End sub btnPress