How to loop this data in VBA? - excel

I have a worksheet (first row headers) where the 3 last columns are as follows: Component 1(column AW), Component 2 (AX) and Number of Components (AY). Number of components value is either 1 or 2. If "Number of components" is 2 then I would like to copy the entire row and paste it twice to the last row of the same worksheet.
If "Number of components"is 1 then I would only like to copy it once.
Earlier there is also a column M that contains the article number and for each copied row I would like the value in column M to be replaced by the value from the corresponding row of column Component 1 / Component 2.
For example in this row the article number in column M is x. As "Number of components" is 2, I would like this whole row to be pasted twice to the last row of the worksheet. By the first time it is pasted, I need column M value to be replaced by 205334 (Component 1 value) and when it is pasted second time I need column M value to be replaced by 96423 (Component 2 value). Is it possible to loop this way? The worksheet has more than a 1000 rows.
I have written the following code to do the copy/paste part, however I'm having trouble to replace the value from Column M with the value from Columns Component 1 and 2.
Dim lastcol As Range
Dim lColumn As Long
Dim lRow As Long
Dim i As Long
lColumn = Cells(1, Columns.Count).End(xlToLeft).Column
Set lastcol = Cells(2, lColumn)
For i = 2 To Rows.Count
If lastcol.Value = 2 Then
Cells(i, lColumn).EntireRow.Select
Selection.Copy Sheets("Filtersets Database (2)").Range("A" & Rows.Count).End(xlUp).Offset(1)
Cells(i, lColumn).EntireRow.Select
Selection.Copy Sheets("Filtersets Database (2)").Range("A" & Rows.Count).End(xlUp).Offset(1)
Cells(i, lColumn).EntireRow.Select
ElseIf lastcol.Value = 1 Then
Cells(i, lColumn).EntireRow.Select
Selection.Copy Sheets("Filtersets Database (2)").Range("A" & Rows.Count).End(xlUp).Offset(1)
End If
Next i
Thank you in advance!

This should do what you want.
Option Explicit
Sub CopySomeThings()
Dim ws As Worksheet
Dim rngDst As Range
Dim lastcol As Long
Dim lastrow As Long
Dim i As Long
Set ws = ActiveSheet ' Sheets("Filtersets Database (2)")
lastrow = ws.Range("A" & Rows.Count).End(xlUp).Row
lastcol = ws.Cells(1, Columns.Count).End(xlToLeft).Column
Set rngDst = ws.Range("A" & lastrow + 1)
For i = 2 To lastrow
With ws
If .Cells(i, lastcol).Value = 2 Then
.Rows(i).Copy rngDst
.Cells(rngDst.Row, "M").Value = .Cells(i, lastcol - 2)
Set rngDst = rngDst.Offset(1)
.Rows(i).Copy rngDst
.Cells(rngDst.Row, "M").Value = .Cells(i, lastcol - 1)
Set rngDst = rngDst.Offset(1)
ElseIf .Cells(i, lastcol) = 1 Then
.Rows(i).Copy rngDst
.Cells(rngDst.Row, "M").Value = .Cells(i, lastcol - 2)
Set rngDst = rngDst.Offset(1)
End If
End With
Next i
End Sub

Related

Filter & Delete Rows for the particular Column having specific value in Row 1 (Header)

I have a below code which find the particular value in cell, if that cell is having the value it will delete that row.
Sub FindDeleteBis()
Dim sh As Worksheet, lastRow As Long, rngDel As Range, i As Long
Set sh = ActiveSheet 'use here your sheet
lastRow = sh.Range("A" & Rows.count).End(xlUp).Row
For i = 1 To lastRow
Select Case sh.Range("A" & i).value
Case "ca-cns", "ca-dtc", "ca-ext", "ca-ns", "ca-ssbo" 'add here whatever string you need
If rngDel Is Nothing Then
Set rngDel = sh.Range("A" & i)
Else
Set rngDel = Union(rngDel, sh.Range("A" & i))
End If
End Select
Next
If Not rngDel Is Nothing Then rngDel.EntireRow.Delete
End Sub
But the above code works well when there are limited rows (10K), but when I want to delete 40K rows from 140K it's taking time.
How can we reduce the time?
Note: The above code works only if the particular values are in column A, I would like to have a solution where the column is selected on the basis of Value in Header (Row 1). The heading for the particular column will be "Stream"
Try this code, please. It will find a header name "Stream" for the column containing the strings to be used and do the job only if such a string header exists. The code is commented and I hope it will do what (I understood) it should:
Sub FindDeleteBisMarkedColumn()
Dim sh As Worksheet, arr As Variant, rng As Range, rngDel As Range
Dim lastRow As Long, lastCol As Long, colSort As Range, colS As Long
Set sh = ActiveSheet 'use here your sheet to be processed
lastCol = sh.Cells(1, Columns.count).End(xlToLeft).Column 'last column based on the first row
'Finding the column to be sorted (the one containing the header "Stream":_____________________________________
Set colSort = sh.Range(sh.Range("A1"), sh.Cells(1, lastCol)).Find("Stream") 'the cell keeping the "Stream" header
If colSort Is Nothing Then MsgBox "A column header named ""Stream"" must exist in the first row..." & vbCrLf & _
"It is used to determine the column where the search data exists.": Exit Sub
'_____________________________________________________________________________________________________________
colS = colSort.Column 'column number of the column to be sorted
lastRow = sh.Cells(Rows.count, colS).End(xlUp).Row 'last row calculated for column to be sorted
'Create a new column to reorder the range after sorting________________________________________________________
sh.Cells(1, lastCol + 1).value = "SortOrder"
sh.Cells(2, lastCol + 1).value = 1: sh.Cells(3, lastCol + 1).value = 2 'set the list elements to be filled down
sh.Range(sh.Cells(2, lastCol + 1), sh.Cells(3, lastCol + 1)).AutoFill _
Destination:=sh.Range(sh.Cells(2, lastCol + 1), sh.Cells(lastRow, lastCol + 1))
'_______________________________________________________________________________________________________________
Set rng = sh.Range(sh.Range("A1"), sh.Cells(lastRow, lastCol + 1)) 'define the whole range to be processed
arr = Array("ca-cns", "ca-dtc", "ca-ext", "ca-ns", "ca-ssbo") 'the array keeping the string to be used
rng.Sort Key1:=colSort, Order1:=xlAscending, Header:=xlYes 'sorting based on the 'colSort' range
Dim El As Variant, i As Long, j As Long, firstAddr As String
Dim lastAddr As String, boolFound As Boolean, iNew As Long
For Each El In arr 'iterate between each conditions array elements
For i = 2 To lastRow 'iterate between the cells of the 'colSort' range
If sh.Cells(i, colS).value = El Then 'when first matching cell has been found
firstAddr = sh.Cells(i, colS).Address: iNew = i 'matching cell 'firstAddr' is defined
For j = i To lastRow 'iterate on the same 'colSort' range, until the last identic cell
If sh.Cells(j, colS).value <> sh.Cells(j + 1, colS).value Then 'for the last matching cell
lastAddr = sh.Cells(j, colS).Address: boolFound = True: Exit For ''lastAddr' defined
End If
Next j
End If
If firstAddr <> "" Then 'if the array element has been found
sh.Range(firstAddr & ":" & lastAddr).EntireRow.Delete 'the range to be deleted is built and deleted
firstAddr = "": lastAddr = "" 'firstAddr and lastAddr are re initializated
i = iNew - 1: boolFound = False 'i (the iteration variable) is reinitialized at row after the deletion
End If
Next i
Next
lastRow = sh.Cells(Rows.count, colS).End(xlUp).Row 'last row is redefined, according to # of rows reamained
Set rng = sh.Range(sh.Range("A1"), sh.Cells(lastRow, lastCol + 1)) 'redefin the sorted area based on 'lastRow'
rng.Sort Key1:=sh.Cells(1, lastCol + 1), Order1:=xlAscending, Header:=xlYes 'sort the range on the 'SortOrder' col
sh.Range(sh.Cells(1, lastCol + 1), sh.Cells(lastRow, lastCol + 1)).Clear 'clear of 'SortOrder' column
End Sub

VBA: Cut a range of columns and paste it to bottom of data in first three columns

I have data in an excel file in which there is data for separated into three columns:
Date (column A), number (column B), number (column C).
This sequence gets repeated to column UI. I would like to cut the data in every three columns and paste it the last row + 1 in column a,b,c so I only have three columns of data. I am having trouble accounting for three columns of data in my code.
`Sub movedata()
Application.ScreenUpdating = False
Dim i As Integer
Set ws = ThisWorkbook.Sheets("Cashflow Chart")
With ws
lastColumn = Cells(1, Columns.Count).End(xlToLeft).Column 'get last column using Row 1
For i = 4 To lastcolumn 'loop though each column starting from 4
Set Rng = .Range(.Cells(1, i), .Cells(.Cells(.Rows.Count, i).End(xlUp).Row, i)) 'set range to copy
.Range("A" & .Cells(.Rows.Count, "A").End(xlUp).Row + 1).Resize(Rng.Rows.Count).Value = Rng.Value
End With
Application.ScreenUpdating = True
End Sub`
Fundimentally, change the For loop to step by 3's
Also, moving the data via a Variant Array will be faster, plus a few other things
Sub MoveData()
Application.ScreenUpdating = False
Dim i As Long
Dim Data As Variant
Dim LastColumn As Long
Dim InsertRow As Long
With ThisWorkbook.Sheets("Cashflow Chart")
LastColumn = .Cells(1, .Columns.Count).End(xlToLeft).Column 'get last column using Row 1
InsertRow = .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0).Row 'get insert point using column A
For i = 4 To LastColumn Step 3 'loop though each column starting from 4, step by 3
Data = .Range(.Cells(1, i + 2), .Cells(.Rows.Count, i).End(xlUp)).Value 'copy range to variant array
.Cells(InsertRow, 1).Resize(UBound(Data, 1), 3).Value = Data 'place data at end of column A data
InsertRow = InsertRow + UBound(Data, 1) 'increment insert point
Next
.Cells(1, 4).Resize(InsertRow, LastColumn - 3).ClearContents 'clear old data
End With
Application.ScreenUpdating = True
End Sub

How do I round columns based on heading type

I have a table consisting of strings and numbers. Row one contains the heading and row two contains the unit type (percent and dollars). I would like to round the numbers in the column based on the heading in row two.
At the moment I am selecting the columns individually. Is there a way to round the column based on the heading in row two?
Sub Round()
Dim Lastrow As Long
Lastrow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row 'Determine
last row
For Each cell In ActiveSheet.Range("R3:R" & Lastrow)
cell.Value = WorksheetFunction.Round(cell.Value, 2) 'Round dollars to 2 places
Next cell
For Each cell In ActiveSheet.Range("AB3:AB" & Lastrow)
cell.Value = WorksheetFunction.Round(cell.Value, 2)
Next cell
For Each cell In ActiveSheet.Range("Q3:Q" & Lastrow)
cell.Value = WorksheetFunction.Round(cell.Value, 1) 'Round percentages to 1 places
Next cell
....
End Sub
You were close enough, just needed a bit from both of those tries together. Please see if the below helps, I've added an alternative using arrays as well (if you have lots of data, it will be much faster):
Sub RoundRanges()
Dim ws As Worksheet: Set ws = ActiveSheet 'better use something like: ActiveWorkbook.Sheets("Sheet name here")
Dim lRow As Long: lRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row 'get last row
Dim lCol As Long: lCol = ws.Cells(2, ws.Columns.Count).End(xlToLeft).Column 'get last column
Dim R As Long, C As Long
For C = 1 To lCol 'iterate through each column
Select Case ws.Cells(2, C) 'get the text of the cell 2...
Case "Percent"
For R = 3 To lRow 'iterate through each row
ws.Cells(R, C) = WorksheetFunction.Round(ws.Cells(R, C).Value, 1) 'apply the desired calculation
Next R
Case "Dollars"
For R = 3 To lRow 'iterate through each row
ws.Cells(R, C) = WorksheetFunction.Round(ws.Cells(R, C).Value, 2) 'apply the desired calculation
Next R
End Select
Next C
'ALTERNATIVE:
'Dim arrData As Variant: arrData = ws.Range(ws.Cells(1, 1), ws.Cells(lRow, lCol))
'For R = LBound(arrData) + 2 To UBound(arrData) 'skip first 2 rows
' For C = LBound(arrData, 2) To UBound(arrData, 2)
' If arrData(2, C) = "Percent" Then
' arrData(R, C) = Round(arrData(R, C), 1)
' ElseIf arrData(2, C) = "Dollars" Then
' arrData(R, C) = Round(arrData(R, C), 2)
' End If
' Next C
'Next R
'ws.Range(ws.Cells(1, 1), ws.Cells(lRow, lCol)) = arrData
End Sub

Displaying merged cell data in a For loop

I'm trying to display the contents of a merged cell in a For loop in Excel using VBA.
I have the a worksheet with very simple data in it
Here is my code:
'finding last record in my initial list
sheet_last_row = Sheets("mylist").Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To sheet_last_row
last_row = Sheets("results").Cells(Rows.Count, 1).End(xlUp).Row
If Sheets("mylist").Cells(i, 1).Value = 2 Then
'test if cell is merged
If Sheets("mylist").Cells(i, 2).MergeCells Then
RowCount = Sheets("mylist").Cells(i, 2).Value
End If
Sheets("mylist").Cells(i, 1).EntireRow.Copy Sheets("results").Cells(last_row + 1, 1)
End If
Next i
I'm getting the following result with this code;
I'm new at this. Can anyone show me how to make this work.
You could try:
Option Explicit
Sub test()
Dim LastRowA As Long, LastRowB, LastRowC As Long, LastRowE As Long, MaxRow As Long
Dim cell As Range, rng As Range
With ThisWorkbook.Worksheets("Sheet1")
'Find the lastrow for all the available columns
LastRowA = .Cells(.Rows.Count, "A").End(xlUp).Row
LastRowB = .Cells(.Rows.Count, "B").End(xlUp).Row
LastRowC = .Cells(.Rows.Count, "C").End(xlUp).Row
'Get the longer last row in order to avoid losing data if the last cell of a column is merge or empty
MaxRow = WorksheetFunction.Max(LastRowA, LastRowB, LastRowC)
'Set the area to loop
Set rng = .Range("A2:C" & MaxRow)
'Start looping
For Each cell In rng
'If the cell is merger
If cell.MergeCells Then
'Find the last row of column E
LastRowE = .Cells(.Rows.Count, "E").End(xlUp).Row
'Paste cell value in column E
.Range("E" & LastRowE + 1).Value = cell.Value
'Paste cell address in column F
.Range("F" & LastRowE + 1).Value = cell.Address
End If
Next
End With
End Sub
Results:

Copying only specific cells to different sheets if certain conditions are true

I am working with 4 rows (test bed for my code) and each product is allocated 2 rows: Data range is A1:E5
Fizzy Drink Australia Perth no sugar High
Fizzy Drink 3 5 7 5
Still water Australia Perth flavoured High
Still water 4 7 5 4
The above is on sheet 1 and there's a sheet for each produce i.e. total 3 sheets. I'm using a For loop in column 'A' to find the product and then copy the text in each of the 4 columns to the right onto the respective product sheets in columns H1:K1. This text acts as headers for each product sheet, so the headers are not the same for each product. Each product's text must be copied to the correct product sheet.
I'm having problems copying the text attached in the first row against each product in column 'A', as the 2nd row has values. The format is same for all the products - 2 rows - first row for text and second for formulas.
The challenge (which I have failed miserably) is to make the code copy text in columns B:E for each particular product.
The text can change on often basis so if the code can identify the product in column 'A' and copy/paste the text that would be fantastic.
Option Explicit
Sub copy_Text_Formulas_to_sheets
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim ws3 As Worksheet
Dim Lastrow As Long
Dim Lastrow1 As Long
Dim Lastrow2 As Long
Dim i As Integer
Dim j As Integer
Set ws1 = ThisWorkbook.Worksheets("Key") 'this is the sheet I'm pulling data from
Set ws2 = ThisWorkbook.Worksheets("Fizzy Drink") 'this is the worksheet I'm pulling data into for Prd1
Set ws3 = ThisWorkbook.Worksheets("still water") 'this is the worksheet I'm pulling data into for Prd2
Lastrow = ws1.Cells(ws1.Rows.Count, "A").End(xlUp).Row
Lastrow1 = ws2.Cells(ws2.Rows.Count, "A").End(xlUp).Row
Lastrow2 = ws3.Cells(ws3.Rows.Count, "A").End(xlUp).Row
For i = 1 To Lastrow
For j = 1 To Lastrow
If ws1.Cells(i, "A").Value = "Fizzy Drink" And ws1.Cells(i, "B").Value = "Australia" And _
ws1.Cells(i, "C").Value = "Perth" And ws1.Cells(i, "D").Value = "no sugar" And ws1.Cells(i, "E").Value = "High" Then
ws1.Range("B" & i, "E" & i).Copy 'copy row with text from B to E including all formatting
ws2.Select
ws2.Range("H1:K1").PasteSpecial xlPasteValues
'If the above conditions are not met msg user
End If
If ws1.Cells(j, "A").Value = "Fizzy Drink" And ws1.Range(i,"B:E").HasFormlua Then
ws2.Range("B2:E2") = ws1.Range(j, "H:K") 'copy the formulas in row B:E with relative references
'If the above conditions are not met msg user
End If
If ws1.Cells(i, "A").Value = "still water" And ws1.Cells(i, "B").Value = "Australia" And _
ws1.Cells(i, "C").Value = "Perth" And ws1.Cells(i, "D").Value = "flavoured" And ws1.Cells(i, "E").Value = "High" Then
ws1.Range("B" & i, "E" & i).Copy 'copy row with text from B to E including all formatting
ws3.Select
ws3.Range("H1:K1").PasteSpecial xlPasteValues 'copy including all formatting
'If the above conditions are not met msg user
End If
If ws1.Cells(j, "A").Value = "still water" And ws1.Range(i, "B:E").HasFormlua Then
ws2.Range("B2:E2") = ws1.Range(j, "H:K") 'copy the formulas in row B:E with relative references
'If the above conditions are not met msg user
End If
Next j
Next i
On Error Resume Next
ws2.Range("B2:E2").AutoFill Destination:=Range("B2:E" & Lastrow1) 'copy formula in row to down to lastrow
ws3.Range("B2:E2").AutoFill Destination:=Range("B2:E" & Lastrow2) 'copy formula in row to down to lastrow
This should help. I didn't do anything with the header row because I don't know why you would have to change it one, let alone once for each record.
Sub copy_Text_Formulas_to_sheets1()
Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
Dim Lastrow As Long, i As Long
Dim msg as String
Set ws1 = ThisWorkbook.Worksheets("Key") 'this is the sheet I'm pulling data from
Set ws2 = ThisWorkbook.Worksheets("Fizzy Drink") 'this is the worksheet I'm pulling data into for Prd1
Set ws3 = ThisWorkbook.Worksheets("still water") 'this is the worksheet I'm pulling data into for Prd2
With ws1
Lastrow = .Cells(ws1.rowS.Count, "A").End(xlUp).Row
MsgBox "Last Row:" & Lastrow
For i = 1 To Lastrow
msg = msg & .Cells(i, "A") & vbcrlf
If IsNumeric(.Cells(i, 2)) Then
If .Cells(i, "A").value = "Fizzy Drink" Then
.Range(.Cells(i, "B"), .Cells(i, "E")).Copy getNextRow(ws2, "H")
ElseIf .Cells(i, "A").value = "Still water" Then
.Range(.Cells(i, "B"), .Cells(i, "E")).Copy getNextRow(ws3, "H")
End If
End If
Next
MsgBox "Range B2 is Numeric:" & .Cells(2, 2) & vbCrLF & "Range B3 is Numeric:" & .Cells(3, 2)
MsgBox "Range B2 has formula:" & .Cells(2, 2).HasFormula & vbCrLF & "Range B3 has formula:" & .Cells(3, 2).HasFormula
MsgBox msg
End With
End Sub
Function getNextRow(xlWorksheet As Worksheet, colmnLetter As String) As Range
Set getNextRow = xlWorksheet.Cells(rowS.Count, colmnLetter).End(xlUp).Offset(1, 0)
End Function
I added a couple of message to see what's up. Let me know what you get back. Can you provide a download link with sample data?

Resources