Looping functions in VBA - excel

My goal is to build a looping function that can take the *data and convert it into the *Goal Output
This is as far as I can make it with the code, my fundamental question is how to I nest my code inside of VBA to run 3 lines of code and then skip to line 6
*Data - sheet1
Layout
Machine 1
Work Center 1
Date
Machine 2
Work Center 2
Date
*Output - sheet2
Machine
Work Center
Date
Machine 1
Work Center 1
Date
Machine 1
Work Center 1
Date
*Goal Output - sheet 3
Machine
Work Center
Date
Machine 1
Work Center 1
Date
Machine 2
Work Center 2
Date
Code
Sub Fill_Data()
Sheet2.Activate
Set ws = Sheets("Sheet1")
Set ws2 = Sheets("Sheet2")
emptyrow = Cells(Rows.Count, 1).End(xlUp).Row + 1
Dim i As Integer
For i = 1 To 3
ws.Cells(i, 1).Copy
ws2.Cells(emptyrow, i).PasteSpecial
Next i
emptyrow = emptyrow + 1
End Sub

The below creates the loop you are asking for, you would just need to modify to your specific need.
Sub Fill_Data()
Set ws = Sheets("Sheet1")
Set ws2 = Sheets("Sheet2")
ws.Range("A1").Activate
emptyrow = Cells(Rows.Count, 1).End(xlUp).Row + 1
Dim i As Integer
Dim x As Integer
x = 1
For i = 1 To emptyrow
ws.Range(Cells(i, 1), Cells(i + 2, 1)).copy
ws2.Cells(x, 1).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
i = i + 4
x = x + 1
Next i
End Sub

No need to nest any loops, you just need a couple extra incrementers to track everything.
Sub Fill_Data()
Dim ws As Worksheet
Dim ws2 As Worksheet
Set ws = Worksheets("Sheet1")
Set ws2 = Worksheets("Sheet2")
Dim emptyrow As Long
Dim lr As Long
Dim col As Long
Dim i As Long
With ws2
emptyrow = .Cells(Rows.Count, 1).End(xlUp).Row + 1
If emptyrow = 2 Then 'Populate Headers
.Cells(1, 1).Value = "Machine"
.Cells(1, 2).Value = "Work Center"
.Cells(1, 3).Value = "Date"
End If
End With
col = 1
With ws
lr = .Cells(Rows.Count, 1).End(xlUp).Row
For i = 1 To lr
If Not .Cells(i, 1).Value = "" And Not IsEmpty(.Cells(i, 1).Value) Then 'Skip blanks
ws2.Cells(emptyrow, col).Value = .Cells(i, 1).Value
If col = 3 Then 'Reset column and increment row
col = 1
emptyrow = emptyrow + 1
Else
col = col + 1
End If
End If
Next i
End With
End Sub

Transpose Groups of Data
Option Explicit
Sub TransposeGroupsOfData()
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim sws As Worksheet: Set sws = wb.Worksheets("Sheet1")
Dim slRow As Long: slRow = sws.Cells(sws.Rows.Count, "A").End(xlUp).Row
Dim dws As Worksheet: Set dws = wb.Worksheets("Sheet2")
Dim dlRow As Long: dlRow = dws.Cells(dws.Rows.Count, "A").End(xlUp).Row
Dim dCell As Range: Set dCell = dws.Cells(dlRow + 1, "A")
Dim sfgr As Long ' Source First Group Row
Dim sr As Long ' Source Row
Dim dco As Long ' Destination Column Offset
For sfgr = 1 To slRow Step 5
sr = sfgr
For dco = 0 To 2
dCell.Offset(, dco).Value = sws.Cells(sr, "A").Value
sr = sr + 1 ' next source row
Next dco
Set dCell = dCell.Offset(1) ' next cell below
Next sfgr
MsgBox "Data exported.", vbInformation
End Sub

Related

How can we compare two columns and copy differences from Sheet2 to Sheet1?

I have two ranges on two sheets.
I am trying to compare these two lists for differences, and copy any differences from Sheet2 to Sheet1. Here is my code. I think it's close, but something is off, because all if does is delete row 14 on Sheet1 and no different cells from Sheet2 are copied to Sheet1. What's wrong here?
Sub Compare()
Dim lastRow1 As Integer
Dim lastRow2 As Integer
Dim foundTrue As Boolean
lastRow1 = Sheets("Sheet1").Cells(Sheets("Sheet1").Rows.Count, "A").End(xlUp).Row
lastRow2 = Sheets("Sheet2").Cells(Sheets("Sheet2").Rows.Count, "E").End(xlUp).Row
For i = 2 To lastRow2
foundTrue = False
For j = 2 To lastRow1
If Sheets("Sheet2").Cells(i, 1).Value = Sheets("Sheet1").Cells(j, 1).Value Then
foundTrue = True
Exit For
End If
Next j
If Not foundTrue Then
Sheets("Sheet2").Cells(i).Copy Destination:=Sheets("Sheet1").Rows(lastRow1 - 1)
End If
Next i
Debug.Print i
End Sub
I want to end up with this.
Nothing that a debug session can't reveal.
You need to copy to lastrow + 1, not lastrow - 1.
After copying the first value, you need to somehow increase the value for lastRow1. But as you use this value as limit in your (inner) for-loop, you shouldn't modify it. So I suggest you introduce a counter variable that counts how many rows you already copied and use this as offset.
And you have some more mistakes:
Your data in sheet2 is in columns E and F, but you compare the values of column "A" (you wrote Sheets("Sheet2").Cells(i, 1).Value)
The source in your copy-command accesses is .Cells(i). In case i is 10, this would be the 10th cell of your sheet, that is J1 - not the cell E10. And even if it was the correct cell, you would copy only one cell, not two.
Obgligatory extra hints: Use Option Explicit (your variables i and j are not declared), and always use Long, not Integer.
Code could look like (I renamed foundTrue because it hurts my eyes to see True in a variable name)
Dim i As Long, j As Long
For i = 2 To lastRow2
foundValue = False
For j = 2 To lastRow1
If Sheets("Sheet2").Cells(i, 5).Value = Sheets("Sheet1").Cells(j, 1).Value Then
foundValue = True
Exit For
End If
Next j
If Not foundValue Then
addedRows = addedRows + 1
Sheets("Sheet2").Cells(i, 5).Resize(1, 2).Copy Destination:=Sheets("Sheet1").Cells(lastRow1, 1).Offset(addedRows)
End If
Next i
But this leaves a lot room for improvement. I suggest you have a look to the following, in my eyes it's much cleaner and much more easy to adapt. There is still room for optimization (for example read the data into arrays to speed up execution), but that's a different story.
Sub Compare()
Const sourceCol = "E"
Const destCol = "A"
Const colCount = 2
' Set worksheets
Dim sourceWs As Worksheet, destWs As Worksheet
Set sourceWs = ThisWorkbook.Sheets("Sheet2")
Set destWs = ThisWorkbook.Sheets("Sheet1")
' Count rows
Dim lastRowSource As Long, lastRowDest As Long
lastRowSource = sourceWs.Cells(sourceWs.Rows.Count, sourceCol).End(xlUp).Row
lastRowDest = destWs.Cells(destWs.Rows.Count, destCol).End(xlUp).Row
Dim sourceRow As Long, destRow As Long
Dim addedRows As Long
For sourceRow = 2 To lastRowSource
Dim foundValue As Boolean
foundValue = False
For destRow = 2 To lastRowDest
If sourceWs.Cells(sourceRow, sourceCol).Value = destWs.Cells(destRow, destCol).Value Then
foundValue = True
Exit For
End If
Next destRow
If Not foundValue Then
addedRows = addedRows + 1
sourceWs.Cells(sourceRow, sourceCol).Resize(1, colCount).Copy Destination:=destWs.Cells(lastRowDest, 1).Offset(addedRows)
End If
Next sourceRow
End Sub
Copy Differences (Loop)
A Quick Fix
Option Explicit
Sub Compare()
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim ws1 As Worksheet: Set ws1 = wb.Worksheets("Sheet1")
Dim lRow1 As Long: lRow1 = ws1.Cells(ws1.Rows.Count, "A").End(xlUp).Row
Dim fRow1 As Long: fRow1 = lRow1
Dim ws2 As Worksheet: Set ws2 = wb.Worksheets("Sheet2")
Dim lRow2 As Long: lRow2 = ws2.Cells(ws2.Rows.Count, "E").End(xlUp).Row
Dim i As Long, j As Long
For i = 2 To lRow2
For j = 2 To lRow1
If ws2.Cells(i, "E").Value = ws1.Cells(j, "A").Value Then Exit For
Next j
' Note this possibility utilizing the behavior of the For...Next loop.
' No boolean necessary.
If j > lRow1 Then ' not found
fRow1 = fRow1 + 1
ws2.Cells(i, "E").Resize(, 2).Copy ws1.Cells(fRow1, "A")
End If
Next i
MsgBox "Found " & fRow1 - lRow1 & " differences.", vbInformation
End Sub

Coloring row when condition is met

I am trying to color the cell when condition is met and valid value for package of a product is found in another column in a different sheet.
There is a problem with the if statement.
Sub validation()
Dim lastRow_s As Long
Dim lastRow_m As Long
lastRow_s = Sheets("product").Cells(Rows.Count, "D").End(xlUp).Row
lastRow_m = Sheets("product").Cells(Rows.Count, "H").End(xlUp).Row
For i = 2 To lastRow_s
For j = 2 To lastRow_m
If Sheets("product").Cells(i,"D").Value =
Sheets("valid_package").Cells(j,"A").Value And
Sheets("product").Cells(i, "H").Value =
Sheets("valid_package").Cells(j,"B").Value Then
Sheets("product").Cells(i, "H").Value = vbGreen
End If
Next j
Next i
End Sub
I am trying to iterate over two columns to make sure that the product in column D has a valid package in column H in the product sheet. In the valid_package sheet there is a column for product and package that are valid for this products, so valid_package looks like this:
Product (this is column A from valid package)
Package (this is column B from valid package)
Product A
65x3
Product A
63x3
Product B
65x3
Product B
60x3
Product C
15
Product C
10x3
Product C
15
Product D
10
The product sheet is like this if you take only the two columns:
Product (this is column D from products)
Package (this is column H from products)
Product A
65x3
Product C
63x3
Product B
65x3
Product C
60x3
Product A
15
Product B
10x3
Product C
15
Product E
10
Product C
15
Product D
10
I want to highlight correct package in column H for sheet product or incorrect package in column H for sheet product, it doesn't matter what is colored.
I get
Expected: "line number or label or statement or end of statement.
Color Conditionally Matching Cells
Option Explicit
Sub TestAll()
ValidationQuickFix
ValidationReadable
ValidationEfficient
' Result on 1000 matches in 10000 rows of destination
' with only 10 rows of unique source values:
' Quick Fix: 6,1875
' Readable: 2,21484375
' Efficient: 0,87890625
End Sub
Sub ValidationQuickFix()
Dim t As Double: t = Timer
ThisWorkbook.Activate
Dim lastRow_s As Long
lastRow_s = Worksheets("valid_package").Cells(Rows.Count, "A").End(xlUp).Row
Dim lastRow_d As Long
lastRow_d = Worksheets("product").Cells(Rows.Count, "D").End(xlUp).Row
Dim i As Long, j As Long
For i = 2 To lastRow_d
For j = 2 To lastRow_s
If Worksheets("product").Cells(i, "D").Value = _
Worksheets("valid_package").Cells(j, "A").Value Then
If Worksheets("product").Cells(i, "H").Value = _
Worksheets("valid_package").Cells(j, "B").Value Then
Worksheets("product").Cells(i, "H").Interior.Color = vbGreen
Else
Worksheets("product").Cells(i, "H").Interior.Color = xlNone
End If
End If
Next j
Next i
Debug.Print "Quick Fix: " & Timer - t
End Sub
Sub ValidationReadable()
Dim t As Double: t = Timer
Dim wb As Workbook: Set wb = ThisWorkbook
Dim sws As Worksheet: Set sws = wb.Worksheets("valid_package")
Dim slRow As Long: slRow = sws.Cells(sws.Rows.Count, "A").End(xlUp).Row
Dim dws As Worksheet: Set dws = wb.Worksheets("product")
Dim dlRow As Long: dlRow = dws.Cells(dws.Rows.Count, "D").End(xlUp).Row
Dim i As Long, j As Long
For i = 2 To dlRow
For j = 2 To slRow
If dws.Cells(i, "D").Value = sws.Cells(j, "A").Value Then
If dws.Cells(i, "H").Value = sws.Cells(j, "B").Value Then
dws.Cells(i, "H").Interior.Color = vbGreen
Else
dws.Cells(i, "H").Interior.Color = xlNone
End If
End If
Next j
Next i
Debug.Print "Readable: " & Timer - t
End Sub
Sub ValidationEfficient()
Dim t As Double: t = Timer
Dim wb As Workbook: Set wb = ThisWorkbook
Dim sws As Worksheet: Set sws = wb.Worksheets("valid_package")
Dim slRow As Long: slRow = sws.Cells(sws.Rows.Count, "A").End(xlUp).Row
Dim srg1 As Range: Set srg1 = sws.Range("A2:A" & slRow)
Dim srg2 As Range: Set srg2 = sws.Range("B2:B" & slRow)
Dim dws As Worksheet: Set dws = wb.Worksheets("product")
Dim dlRow As Long: dlRow = dws.Cells(dws.Rows.Count, "D").End(xlUp).Row
Dim drg1 As Range: Set drg1 = dws.Range("D2:D" & dlRow)
Dim drg2 As Range: Set drg2 = dws.Range("H2:H" & dlRow)
Dim ddrg As Range
Dim dCell As Range
Dim sIndex As Variant
Dim dr As Long
For dr = 1 To drg1.Rows.Count
sIndex = Application.Match(drg1.Cells(dr).Value, srg1, 0)
If IsNumeric(sIndex) Then
If drg2.Cells(dr).Value = srg2.Cells(sIndex).Value Then
If ddrg Is Nothing Then
Set ddrg = drg2.Cells(dr)
Else
Set ddrg = Union(ddrg, drg2.Cells(dr))
End If
End If
End If
Next dr
If Not ddrg Is Nothing Then
drg2.Interior.Color = xlNone
ddrg.Interior.Color = vbGreen
End If
Debug.Print "Efficient: " & Timer - t
End Sub
Please, test the next code. It should be fast, using Find, placing the range to be colored in a Union range and coloring it at the code end. I hope that I correctly understood what you want and mostly what you have...
Sub validation()
Dim shP As Worksheet, shVP As Worksheet, rngColor As Range, rngA As Range, rngB As Range
Dim lastRow_P As Long, lastRow_VP As Long, cellMatch As Range, i As Long
Set shP = Sheets("product")
Set shVP = Sheets("valid_package")
lastRow_P = shP.cells(rows.Count, "D").End(xlUp).row
lastRow_VP = shVP.cells(rows.Count, "A").End(xlUp).row
Set rngA = shVP.Range("A2:A" & lastRow_VP)
For i = 2 To lastRow_P
Set cellMatch = rngA.Find(what:=shP.cells(i, "D").Value, LookIn:=xlValues, Lookat:=xlWhole)
If Not cellMatch Is Nothing Then
If cellMatch.Offset(0, 1).Value = shP.cells(i, "H").Value Then
If rngColor Is Nothing Then
Set rngColor = shP.cells(i, "H")
Else
Set rngColor = Union(rngColor, shP.cells(i, "H"))
End If
End If
End If
Next i
If Not rngColor Is Nothing Then rngColor.Interior.color = vbGreen
End Sub

Loop rows to copy from one sheet's columns to another sheet

I need to use data from one sheet to fill in another sheet in the same workbook.
Using sheet1's data:
Column C's item will be copied to Sheet2 and any relevant information will be copied over as well.
Then Column D's item will be copied to the next row with its relevant information.
This will be repeated until all rows in Sheet1 are copied over to Sheet2.
(Note: I put this macro as a button in another sheet so I'm referencing each sheet in my code.)
NumRows = Worksheets("Sheet1").Range("C2", Range("C2").End(xlDown)).Rows.Count
' Select cell, *first line of data*.
Worksheets("Sheet1").Range("C2").Select
' Set Do loop to stop when ten consecutive empty cells are reached. (Make sure it's safely run; ignore)
j = 4
Do Until IsEmpty(ActiveCell) And IsEmpty(ActiveCell.Offset(10, 0))
For i = 2 To NumRows
j = j + 1
Worksheets("Sheet1").Cells(i, "C").Value = Worksheets("Sheet2").Cells(j, "C").Value
Worksheets("Sheet1").Cells(i, "A").Value = Worksheets("Sheet2").Cells(j, "A").Value
Worksheets("Sheet1").Cells(i, "B").Value = Worksheets("Sheet2").Cells(j, "B").Value
Worksheets("Sheet1").Cells(i, "E").Value = Worksheets("Sheet2").Cells(j, "D").Value
' New row for next item
j = j + 1
Worksheets("Sheet1").Cells(i, "D").Value = Worksheets("Sheet2").Cells(j, "C").Value
Worksheets("Sheet1").Cells(i, "A").Value = Worksheets("Sheet2").Cells(j, "A").Value
Worksheets("Sheet1").Cells(i, "B").Value = Worksheets("Sheet2").Cells(j, "B").Value
Worksheets("Sheet1").Cells(i, "E").Value = Worksheets("Sheet2").Cells(j, "D").Value
' Step down 1 row from present location.
ActiveCell.Offset(1, 0).Select
Next
Loop
Application.ScreenUpdating = True
End Sub
Your code is copying from sheet2 to sheet1.
Option Explicit
Sub Macro1()
Dim j As Long, i As Long, c As Long
Dim ws2 As Worksheet, lastrow As Long
Set ws2 = Sheets("Sheet2")
j = 1
Application.ScreenUpdating = False
With Sheets("Sheet1")
lastrow = .Cells(.Rows.Count, "C").End(xlUp).Row
For i = 2 To lastrow
For c = 3 To 4
If Len(.Cells(i, c)) > 0 Then
j = j + 1
ws2.Cells(j, "A") = .Cells(i, "A")
ws2.Cells(j, "B") = .Cells(i, "B")
ws2.Cells(j, "C") = .Cells(i, c)
ws2.Cells(j, "D") = .Cells(i, "E")
End If
Next
Next
End With
Application.ScreenUpdating = True
MsgBox j-1 & " rows copied", vbInformation
End Sub
Unpivot Data
The title says it all: it's a job for Power Query. Yet, here's my stab at VBA.
Option Explicit
Sub UnpivotData()
Const ProcTitle As String = "Unpivot Data"
Const sName As String = "Sheet1"
Dim ssCols As Variant: ssCols = VBA.Array(1, 2, 5)
Dim smCols As Variant: smCols = VBA.Array(3, 4)
Const dName As String = "Sheet2"
Const dFirst As String = "A2"
Dim dsCols As Variant: dsCols = VBA.Array(1, 2, 4)
Const dmCol As Long = 3
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
Dim strg As Range: Set strg = sws.Range("A1").CurrentRegion
Dim srCount As Long: srCount = strg.Rows.Count - 1 ' no headers
Dim sdrg As Range: Set sdrg = strg.Resize(srCount).Offset(1)
Dim sdData As Variant: sdData = sdrg.Value
Dim drCount As Long: drCount = srCount * (UBound(smCols) + 1)
Dim dcCount As Long: dcCount = UBound(dsCols) + 2
Dim ddData As Variant: ReDim ddData(1 To drCount, 1 To dcCount)
Dim sdValue As Variant
Dim sr As Long
Dim sc As Long
Dim c As Long
Dim dr As Long
For sr = 1 To srCount
For sc = 0 To UBound(smCols)
sdValue = sdData(sr, smCols(sc))
If Not IsError(sdValue) Then
If Len(CStr(sdValue)) > 0 Then
dr = dr + 1
ddData(dr, dmCol) = sdValue
For c = 0 To UBound(ssCols)
ddData(dr, dsCols(c)) = sdData(sr, ssCols(c))
Next c
'Else ' blank value
End If
'Else ' error value
End If
Next sc
Next sr
Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
Dim dfCell As Range: Set dfCell = dws.Range(dFirst)
Dim ddrg As Range: Set ddrg = dfCell.Resize(dr, dcCount)
ddrg.Value = ddData
MsgBox "Data copied.", vbInformation, ProcTitle
End Sub
I believe you wanna copy data from sheet1 to sheet2 down the line of sheet to data, not sure about asking overriding the data on sheet to, we can create script without looping, please find below if it is helpful.
Sub Copydata()
Dim I As Long
Sheet1.Select
I = Range("C10000").End(xlUp).Row
Range("C2:C" & I).Select
Range(Selection, Selection.End(xlToRight)).Copy
Sheet2.Select
Range("C10000").End(xlUp).Offset(1, 0).Select
ActiveCell.PasteSpecial
End Sub

Unable to arrange evenly scattered information from one sheet to another

I'm trying to arrange some uniformly scattered information from a spreadsheet to another. The information I'm interested in is in Sheet2 and I wish to place them in a customized manner in Sheet1.
I've tried with:
Sub ArrangeInformation()
Dim ws As Worksheet, cel As Range
Set ws = ThisWorkbook.Sheets("Sheet2")
Set tws = ThisWorkbook.Sheets("Sheet1")
For Each cel In ws.Range("A1:A" & ws.Cells(Rows.Count, 1).End(xlUp).row)
tws.Range(cel(1, 1).Address) = cel
Next cel
End Sub
The above script just replicates the same information in Sheet1 how they are in Sheet2.
Data in Sheet2:
How I like to arrange them in Sheet1:
How can I arrange those information in sheet1?
we can use some math to get the correct columns and rows:
Sub ArrangeInformation()
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("Sheet2")
Dim tws As Worksheet
Set tws = ThisWorkbook.Sheets("Sheet1")
Dim i As Long
i = 0
Dim j As Long
j = 0
Dim cel As Range
For Each cel In ws.Range("A1:A" & ws.Cells(ws.Rows.Count, 1).End(xlUp).Row)
If cel <> "" Then
tws.Cells(Int(i / 4) + 1, ((j) Mod 4) + 1) = cel
i = i + 1
j = j + 1
End If
Next cel
End Sub
In the math the 4s are the number of items in each pattern
The INT will increase by 1 every four rounds and the MOD will repeat 1,2,3,4 every 4 rounds.
Just because:
this can be done with a formula:
=INDEX(Sheet2!$A:$A,INT(ROW(1:1)-1)/5+MOD((COLUMN(A:A)-1),5)+1)
where the 2 5s are the pattern and the +1 is the starting row of the data.
Put that in sheet1 A1 and copy over and down.
Maybe use Resize to transfer your data:
Sub Test()
Dim lr As Long, x As Long, y As Long
Dim ws1 As Worksheet: Set ws1 = ThisWorkbook.Sheets("Sheet1")
Dim ws2 As Worksheet: Set ws2 = ThisWorkbook.Sheets("Sheet2")
y = 1
lr = ws1.Cells(ws1.Rows.Count, "A").End(xlUp).Row
For x = 1 To lr Step 5
ws2.Cells(y, 1).Resize(, 4) = Application.Transpose(ws1.Cells(x, 1).Resize(4))
y = y + 1
Next x
End Sub
And propbably faster, you could assign your range to an array:
Sub Test()
Dim arr As Variant
Dim lr As Long, x As Long, y As Long
Dim ws1 As Worksheet: Set ws1 = ThisWorkbook.Sheets("Sheet1")
Dim ws2 As Worksheet: Set ws2 = ThisWorkbook.Sheets("Sheet2")
y = 1
lr = ws1.Cells(ws1.Rows.Count, "A").End(xlUp).Row
arr = ws1.Range("A1:A" & lr)
For x = LBound(arr) To UBound(arr) Step 5
ws2.Cells(y, 1).Resize(, 4) = Array(arr(x, 1), arr(x + 1, 1), arr(x + 2, 1), arr(x + 3, 1))
y = y + 1
Next x
End Sub
You'll need to manage which rows and columns you write to inside your loop. Something like:
Sub ArrangeInformation()
Dim ws As Worksheet, cel As Range
'New variables to manage rows and columns to write to
Dim writecol as integer, writeRow as integer
Set ws = ThisWorkbook.Sheets("Sheet2")
Set tws = ThisWorkbook.Sheets("Sheet1")
'Start in Row 1, Column 1
writeRow = 1
writeCol = 1
For Each cel In ws.Range("A1:A" & ws.Cells(Rows.Count, 1).End(xlUp).row)
tws.Range(writeRow, writeCol) = cel
'Next Column, or reset to 1 and iterate rows
If writeCol = 4 Then
writeCol = 1
writeRow = writeRow + 1
Else
writeCol = writeCol + 1
End If
Next cel
End Sub

After deleting entire rows, newly copied data is shifted down x rows

Before I copy a new set of data into a set of columns I want to delete everything but the headers, which I do using the following code:
wsS.Rows("4:1048560").EntireRow.Delete
I do it like this because the data spreads over column A to AZ and it's not the same rows lenght.
But somehow, the comand leaves cells that contained data previously and are now empty selected, but only for columns A to F (I have 9 blocks of data that are copied and for each block I used a different sub() that are later called within a button). I also apply a filter before on the sheet where I copy the data from.
My problem is that the new copy somehow starts where the other data should have ended. The more ofther I run the code, the more rows down the copy will start. The code for copying was suggested by someone here and I only adapted it slightly to my needs.
The weird thing is that if I run the delete command above in the Immediate Window (or I do a manual delete) and then I run the full code again, the copied data will start as it should in cell A4.
I have also tried to do a select on cell A4 after I delete and then copy the new data. Still no success. And this happens only on the first set of data I copy (columns A to F) -> I used the same code to copy more ranges (A to F, H to M, O to T and so on)
This is the code for one block, namely A to F:
Private Sub CopyDataAtoF()
Dim wsR As Worksheet: Set wsR = ThisWorkbook.Worksheets("Data Raw")
Dim wsS As Worksheet: Set wsS = ThisWorkbook.Worksheets("Scatter Raw")
Dim lrR As Long: lrR = wsR.Cells(wsR.Rows.count, "A").End(xlUp).Row
Dim lrS1 As Long: lrS1 = wsS.Cells(wsS.Rows.count, "A").End(xlUp).Row + 1
Dim lrS2 As Long: lrS2 = wsS.Cells(wsS.Rows.count, "C").End(xlUp).Row + 1
Dim lrS3 As Long: lrS3 = wsS.Cells(wsS.Rows.count, "E").End(xlUp).Row + 1
With wsR
Dim fRng As Range: Set fRng = .Range(.Cells(1, "A"), .Cells(lrR, "AN"))
Dim rngN As Range: Set rngN = .Range(.Cells(2, "N"), .Cells(lrR, "N"))
Dim rngY As Range: Set rngY = .Range(.Cells(2, "Y"), .Cells(lrR, "Y"))
Dim cRng As Range: Set cRng = Union(rngN, rngY)
End With
Application.ScreenUpdating = False
wsS.Rows("4:1048560").EntireRow.Delete Shift:=xlUp
fRng.AutoFilter field:=25, Criteria1:="<>", Operator:=xlFilterValues
fRng.AutoFilter field:=1, Criteria1:="criteria1", Operator:=xlFilterValues
If fRng.SpecialCells(xlCellTypeVisible).CountLarge > 2 Then
cRng.Copy
wsS.Cells(lrS1, "A").PasteSpecial xlPasteValues
With wsS
Dim vis1 As Long: vis1 = .Cells(.Rows.count, "A").End(xlUp).Row
Dim lcS1 As Long: lcS1 = .Cells(lrS1, "A").End(xlToRight).Column + 1
Dim divA As Range: Set divA = .Range(.Cells(lrS1, "A"), .Cells(vis1, "A"))
Dim divY1 As Range: Set divY1 = .Range(.Cells(lrS1, lcS1), .Cells(vis1, lcS1))
divY1.Formula = "=" & .Cells(lrS1, 1).Address(RowAbsolute:=False) & " / 1000"
divA.Value2 = divY1.Value2
divY1.ClearContents
End With
End If
fRng.AutoFilter field:=1, Criteria1:="criteria2", Operator:=xlFilterValues
If fRng.SpecialCells(xlCellTypeVisible).CountLarge > 2 Then
cRng.Copy
wsS.Cells(lrS2, "C").PasteSpecial xlPasteValues
With wsS
Dim vis2 As Long: vis2 = .Cells(.Rows.count, "C").End(xlUp).Row
Dim lcS2 As Long: lcS2 = .Cells(lrS2, "C").End(xlToRight).Column + 1
Dim divC As Range: Set divC = .Range(.Cells(lrS2, "C"), .Cells(vis2, "C"))
Dim divY2 As Range: Set divY2 = .Range(.Cells(lrS2, lcS2), .Cells(vis2, lcS2))
divY2.Formula = "=" & .Cells(lrS2, 3).Address(RowAbsolute:=False) & " / 1000"
divC.Value2 = divY2.Value2
divY2.ClearContents
End With
End If
fRng.AutoFilter field:=1, Criteria1:="criteria3", Operator:=xlFilterValues
If fRng.SpecialCells(xlCellTypeVisible).CountLarge > 2 Then
cRng.Copy
wsS.Cells(lrS3, "E").PasteSpecial xlPasteValues
With wsS
Dim vis3 As Long: vis3 = .Cells(.Rows.count, "E").End(xlUp).Row
Dim lcS3 As Long: lcS3 = .Cells(lrS3, "E").End(xlToRight).Column + 1
Dim divE As Range: Set divE = .Range(.Cells(lrS3, "E"), .Cells(vis3, "E"))
Dim divY3 As Range: Set divY3 = .Range(.Cells(lrS3, lcS3), .Cells(vis3, lcS3))
divY3.Formula = "=" & .Cells(lrS3, 5).Address(RowAbsolute:=False) & " / 1000"
divE.Value2 = divY3.Value2
divY3.ClearContents
End With
End If
wsS.Range("A1").Select
wsR.AutoFilter.ShowAllData
Application.ScreenUpdating = True
End Sub
The issue you are experiencing, is due to the fact that all variable prefixed with lr are storing the index number (invariably) of last row that contained data, before you all delete them.
Based on how the code is written, when you paste new data, it starts from the index number stored in the lr-s.
The solution is to recalculate the value of the lr-s after deleting the data.
Replace the top of your code with the modified codes below, and the codes should work as your expect.
Private Sub CopyDataAtoF()
Dim wsR As Worksheet: Set wsR = ThisWorkbook.Worksheets("Data Raw")
Dim wsS As Worksheet: Set wsS = ThisWorkbook.Worksheets("Scatter Raw")
Application.ScreenUpdating = False
wsS.Rows("4:1048560").EntireRow.Delete Shift:=xlUp
Dim lrR As Long: lrR = wsR.Cells(wsR.Rows.count, "A").End(xlUp).Row
Dim lrS1 As Long: lrS1 = wsS.Cells(wsS.Rows.count, "A").End(xlUp).Row + 1
Dim lrS2 As Long: lrS2 = wsS.Cells(wsS.Rows.count, "C").End(xlUp).Row + 1
Dim lrS3 As Long: lrS3 = wsS.Cells(wsS.Rows.count, "E").End(xlUp).Row + 1
With wsR
Dim fRng As Range: Set fRng = .Range(.Cells(1, "A"), .Cells(lrR, "AN"))
Dim rngN As Range: Set rngN = .Range(.Cells(2, "N"), .Cells(lrR, "N"))
Dim rngY As Range: Set rngY = .Range(.Cells(2, "Y"), .Cells(lrR, "Y"))
Dim cRng As Range: Set cRng = Union(rngN, rngY)
End With
fRng.AutoFilter field:=25, Criteria1:="<>", Operator:=xlFilterValues
fRng.AutoFilter field:=1, Criteria1:="criteria1", Operator:=xlFilterValues
If fRng.SpecialCells(xlCellTypeVisible).CountLarge > 2 Then
The change I made in the code was to move;
Application.ScreenUpdating = False
wsS.Rows("4:1048560").EntireRow.Delete Shift:=xlUp
above;
Dim lrR As Long: lrR = wsR.Cells(wsR.Rows.count, "A").End(xlUp).Row
Dim lrS1 As Long: lrS1 = wsS.Cells(wsS.Rows.count, "A").End(xlUp).Row + 1
... ...
i.e. After deleting the necessary rows, the lr-s are then defined and calculated.
Thank you.

Resources