I've been running this script for a while with not issues, and then today it broke. It's very basic as in I'm just filtering values from one tab and then copying and pasting them onto another tab in the top row. Suddenly though, it will paste the values and then repeat paste the values 19 more times for a total of 20 copy pastes.
Sheets("BSLOG").Select
Range("Q1").Select
Selection.AutoFilter Field:=17, Criteria1:="1"
Range("A1:Q5000").Select
Range("A1:Q5000").Activate
Selection.Copy
Sheets("PENDG TRADES").Select
Range("A1:Q300").Select
ActiveSheet.Paste
Try the next code, please. No need to select, activate anything. In this case, these selections do not bring any benefit, they only consume Excel resources:
Sub testFilterCopy()
Dim shB As Worksheet, shP As Worksheet
Set shB = Sheets("BSLOG")
Set shP = Sheets("PENDG TRADES")
shB.Range("Q1").AutoFilter field:=17, Criteria1:="1"
shB.Range("A1:Q5000").Copy shP.Range("A1")
End Sub
If you want to make the range dynamic (in terms of rows) I can show you how to initially calculate the existing number of rows and set the range to be copied according to it.
FaneDuru is right.
You can also try this code, which I prefer more:
Option Base 1 'This means all array starts at 1. It is set by default at 0. Use whatever you prefer,depending if you have headers or not, etc
Sub TestFilter()
Dim shBSLOG As Worksheet
Dim shPENDG As Worksheet
Dim rngBSLOG As Range
Dim arrBSLOG(), arrCopy()
Dim RowsInBSLOG&
Dim i&, j&, k&
Set shBSLOG = Worksheets("BSLOG")
Set shPENDG = Worksheets("PENDG TRADES")
With shBSLOG
Set rngBSLOG = .Range(.Cells(1, 1), .Cells(5000, 17))
End With
RowsInBSLOG = rngBSLOG.Rows.Count
arrBSLOG = rngBSLOG
ReDim arrCopy(1 To RowsInBSLOG, 1 To 17) 'set the size of the new array as the original array
k = 1 'k is set to 1. This will be used to the row of the new array "arrCopy"
For i = 1 To RowsInBSLOG 'filter the array. From the row "i" = 1 to the total of rows "RowsinBSLOG
If arrBSLOG(i, 1) = 1 Then 'if the first column of the row i is equal to 1, then...
For j = 1 To 17
arrCopy(k, j) = arrBSLOG(i, j) 'copy the row
Next j
k = k + 1 'next copy will be in a new row
End If
Next i 'repeat
With shPENDG
.Range(.Cells(1, 1), .Cells(k, 17)) = arrCopy() 'place the new array in the new sheet
End With
End Sub
Related
I have what I thought would be a simple script, but I have some some strange results.
Goal: Identify specific IDs in a SOURCE sheet using a list of IDs on a Translator Sheet. When found, copy the entire row to and OUTPUT sheet.
The output has strange results that I can't figure out.
Returns all results instead of the limited list. AND results are in weird groupings. (First result is on row 21 and only has 9 rows of data, the next group has 90 rows of data, starting on row 210, then blank rows, then 900 rows of data, etc.
Results do not start in row 2.
Full code is below attempts:
Attempts:
I first searched the SOURCE sheet based on one ID that was hard coded as a simple test and it worked. but when I changed the code to search a range (z21:z), two things happened: 1, it returns everything in the Source file in multiples of 9 as stated above, AND as you can imagine, the time to complete skyrocketed from seconds to minutes. I think I missed a add'l section of code to identify the range??
Old Code:
For K = 1 To xRg.Count
If CStr(xRg(K).Value) = Worksheets("D62D627EB404207DE053D71C880A3E05") Then
xRg(K).EntireRow.Copy Destination:=Worksheets("Output").Range("A2" & J + 1)
J = J + 1
End If
New code:
For K = 1 To xRg.Count
If CStr(xRg(K).Value) = Worksheets("Translator").Range("z21:z" & I)** Then
xRg(K).EntireRow.Copy Destination:=Worksheets("Output").Range("A2" & J + 1)
J = J + 1
End If
1a. I believe one issue is that the Translator list has duplicates. Second, it is searching the entire column Z. Second issue may be that The list in Translator is generated via a formula in column Z, thus if the formula is false, it will insert a "" into the cell. I seek the code to NOT paste those rows where the cell content is either a "" or is a true blank cell. Reason: The "" will cause issues when we try to load the Output file into a downstream system because it is not a true blank cell.
Results in wrong location: When the script is complete, my first result does not start on Row 2 as expected. I thought the clear contents would fix this, but maybe a different clear function is required? or the clear function is in the wrong place? Below screenshot shows how it should show up. It is in the same columns but doesn't start until row 21.
enter image description here
Slow code: I have a command that copies and pastes of the first row from SOURCE to OUTPUT. My code is cumbersome. There has to be an easier way. I am doing this copy and paste just in case the source file adds new columns in the future.
Worksheets("Output").Cells.ClearContents
Sheets("SOURCE").Select
Rows("1:1").Select
Selection.Copy
Sheets("Output").Select
Rows("1:1").Select
ActiveSheet.Paste
Thank you for all your help.
Option Explicit
Sub MoveRowBasedOnCellValuefromlist()
'Updated by xxx 2023.01.18
Dim xRg As Range
Dim xCell As Range
Dim I As Long
Dim J As Long
Dim K As Long
I = Worksheets("SOURCE").UsedRange.Rows.Count
J = Worksheets("Output").UsedRange.Rows.Count
If J = 1 Then
If Application.WorksheetFunction.CountA(Worksheets("Output").UsedRange) = 0 Then J = 0
End If
Worksheets("Output").Cells.ClearContents
Sheets("SOURCE").Select
Rows("1:1").Select
Selection.Copy
Sheets("Output").Select
Rows("1:1").Select
ActiveSheet.Paste
Set xRg = Worksheets("SOURCE").Range("B2:B" & I)
On Error Resume Next
Application.ScreenUpdating = False
'NOTE - There are duplicates in the Translator list. I only want it to paste the first instance.
'Otherwise, I need to create an =Unique() formula and that seems like unnecessary work.
For K = 1 To xRg.Count
If CStr(xRg(K).Value) = Worksheets("Translator").Range("z21:z" & I) Then
xRg(K).EntireRow.Copy Destination:=Worksheets("Output").Range("A2" & J + 1)
J = J + 1
End If
Next
Application.ScreenUpdating = True
End Sub
Try this out - using Match as a fast way to check if a value is contained in your lookup list.
Sub MoveRowBasedOnCellValuefromlist()
Dim c As Range, wsSrc As Worksheet, wsOut As Worksheet, wb As Workbook
Dim cDest As Range, wsTrans As Worksheet, rngList As Range
Set wb = ThisWorkbook 'for example
Set wsSrc = wb.Worksheets("SOURCE")
Set wsOut = wb.Worksheets("Output")
Set wsTrans = wb.Worksheets("Translator")
Set rngList = wsTrans.Range("Z21:Z" & wsTrans.Cells(Rows.Count, "Z").End(xlUp).Row)
ClearSheet wsOut
wsSrc.Rows(1).Copy wsOut.Rows(1)
Set cDest = wsOut.Range("A2") 'first paste destination
Application.ScreenUpdating = False
For Each c In wsSrc.Range("B2:B" & wsSrc.Cells(Rows.Count, "B").End(xlUp).Row).Cells
If Not IsError(Application.Match(c.Value, rngList, 0)) Then 'any match in lookup list?
c.EntireRow.Copy cDest
Set cDest = cDest.Offset(1) 'next paste row
End If
Next c
Application.ScreenUpdating = True
End Sub
'clear a worksheet
Sub ClearSheet(ws As Worksheet)
With ws.Cells
.ClearContents
.ClearFormats
End With
End Sub
I am trying to write a VBA code where I want to populate DATA from a worksheet Range A to AQ spanning over multiple Rows. AQ contains Value "Open" or "Closed". I want to get the rows where AQ value is closed. I tried using the AutoFilter. This is working fine to an extent. But I have to use 2 For loops. One for Each Row and another for Each Column to populate Row wise, column by column into the list box
My Code as follows:
Note : Actual contents start from 6th Row where 6 contains the headers and data starts from 7th Row
Dim i As Long
Dim rowRange As Range
Dim AllData(1 To 1000, 1 To 43) As String
lstRecords.ColumnCount = 43
Set shDSR = mydata1.Sheets("DSR")
last_Row = shDSR.Cells(Rows.Count, 1).End(xlUp).Row
shDSR.AutoFilterMode = False
shDSR.Range("A6:AQ" & last_Row).AutoFilter Field:=43, Criteria1:="CLOSED"
Set rng = shDSR.Range("A6:AQ" & last_Row).SpecialCells(xlCellTypeVisible)
Dim filtrRow() As String
Dim rowCnt As Long
'Me.lstRecords.Clear
rowCnt = 0
If rng.Count > 0 Then
Me.lstRecords.Clear
Me.lstRecords.ColumnCount = rng.Columns.Count
For Each Row In rng.Rows
Me.lstRecords.AddItem
rowCnt = rowCnt +1
filterRow = Range(Row.Address)
'Me.lstRecords.List() = filterRow ''This throws error Type Mismatch so not using
For i = 1 To Row.Columns.Count
AllData(rowCnt, i) = Row.Cells(1, i).Value ''Move to Array
Me.lstRecords.List(rowCnt - 1, i - 1) = filterRow(1, i)'Buggy error when i = 11
Next
Next
'' Following segment works. Add data to Array and then populate ListBox from Array
Me.lstRecords.List() = AllData
Else
MsgBox "No data matches the filter criteria."
End If
Above Code has both approaches
a) Trying to load directly from excel Range (actually using filterRow, but can also directly use range with same issue). But, this approach stops always when i=11 with Invalid property error. I tried changing the data contents etc still same issue
Another Issue when Not taking the array based approach, only one line is added, so in affect only last line is available in the list box
b) Using the AllData array. I load all the row data (matching criteria) into the array and finally populate the listbox from array. THIS WORKS. But I do not like this approach
Can some one please point out where it is going wrong.
Thanks in advance
Problem is that filters create a non contiguous range consisting of areas which you have to iterate separately.
Option Explicit
Sub demo()
Dim mydata1 As Workbook, shDSR As Worksheet
Dim rng As Range, a As Range, r As Range
Dim last_row As Long, n As Long
Dim i As Long, rowCnt As Long
Dim ListData() As String
' change this
Set mydata1 = ThisWorkbook
Set shDSR = mydata1.Sheets("DSR")
With shDSR
.AutoFilterMode = False
last_row = .Cells(.Rows.Count, "AQ").End(xlUp).Row
.Range("A6:AQ" & last_row).AutoFilter Field:=43, Criteria1:="CLOSED"
Set rng = .Range("A6:AQ" & last_row).SpecialCells(xlCellTypeVisible)
.AutoFilterMode = False
End With
' clear listbox
With Me.lstRecords
.Clear
.ColumnCount = rng.Columns.Count
End With
'iterate areas and rows to count visible rows
For Each a In rng.Areas
n = n + a.Rows.Count
Next
rowCnt = 0
If n > 1 Then
' size array
ReDim ListData(1 To n, 1 To rng.Columns.Count)
' fill array
For Each a In rng.Areas
For Each r In a.Rows
rowCnt = rowCnt + 1
For i = 1 To UBound(ListData, 2)
ListData(rowCnt, i) = r.Cells(1, i).Value ''Move to Array
Next
Next
Next
' populate ListBox from Array
Me.lstRecords.List() = ListData
Else
MsgBox "No data matches the filter criteria."
End If
End Sub
I am quite new to VBA so my question may sound silly to some of you.
I have a problem with my code. I am trying to check between 2 sheets(1st: test and 2nd: test data. In the code I am using the code name of the sheets) how may times a criteria/my product is met and based on that number to add that many rows beneath the SKU/product.
What I want to do is, if for my first product/SKU I have stock in 5 different locations, I want to add 5 rows in the first sheet and to see the qty in column D and the location in column E.
TestData tab
The reason why I need to list the quantity in different cells is that the stock is in different locations, so I can not just add in to one cell.
I am also adding screen shots of how my two sheets look like.
I have not add the loop to find the location yet, but I want to understand how to add the rows first.
Sub test()
Dim myrange As Range, testrange As Range, cell As Range, result As Range
Dim i As Long, testlastrow As Long, lastrow As Long
Dim helprng As Range
lastrow = TESTTAB.Range("a" & Rows.Count).End(xlUp).row
testlastrow = TDATA.Range("a" & Rows.Count).End(xlUp).row
Set testrange = TDATA.Range("a2:c" & testlastrow)
Set myrange = TESTTAB.Range("b2:b" & lastrow)
Set result = TESTTAB.Range("d2:e" & testlastrow)
Set helprng = TESTTAB.Range("f2:f" & lastrow)
For Each cell In myrange
For i = 1 To lastrow
If cell.Cells(i, 1) = testrange.Cells(i, 1) Then
result.Cells(i, 1) = testrange.Cells(i, 2)
End If
Next i
Next cell
End Sub
Here is the raw structure you were asking for.
Sub test()
' 011
Dim Rng As Range
Dim Tmp As Variant
Dim Radd As Long ' number of rows to add
Dim R As Long ' row counter
With Tdata
' Range, Cells and Rows Count, all in the same sheet
' exclude caption row(s)
Set Rng = .Range(.Cells(2, "A"), .Cells(.Rows.Count, "A").End(xlUp))
End With
Application.ScreenUpdating = False ' speed up the process
With TestTab
' end the loop in row 2 because row 1 might contain captions
' loop bottom to top because row numbers will change
' below the current row as you insert rwos
' column 1 = "A"
For R = .Cells(.Rows.Count, 1).End(xlUp).Row To 2 Step -1
Tmp = .Cells(R, 1).Value
Radd = Application.CountIf(Rng, Tmp)
If Radd > 1 Then
.Range(.Rows(R + 1), .Rows(R + Radd)).Insert
.Cells(R + 1, 1).Value = Radd ' for testing purposes
End If
Next R
End With
Application.ScreenUpdating = True ' now you look
End Sub
As our Evil Blue Monkey has suggested, inserting blank rows and then populating them may not be the most efficient way. You can copy a row and then click Insert to insert the copied data into a new row. Get the syntax from the Macro recorder if it's of interest. It works with the Range object the same way.
I am trying to copy data from one sheet to another according to matching dates and so far I can do this but the problem is that the most recent data for a corresponding date over writes all other data for the same date.
E.G.
I want to copy data from sheet 2 column 1 (based on the date in column 2)
I want to paste this data into sheet 1 column 2 (Based on the date in column 1)
As can be seen, only the last number from sheet 2 column 1 which corresponds to the respective date is pasted into ALL corresponding dates in sheet 1 column 2.
Instead, if there are two dates, I want two different numbers( from sheet 2 column 1 ) to be pasted into sheet 1 column 2.
My original code is as follows:
Sub Macroturnip()
'
' Macroturnip Macro
'
Dim Row As Double 'row is the row variable for the destination spreadsheet
Dim i As Date
Dim x As Long 'x is the row variable for the source spreadsheet
For Row = 1 To 825
i = Sheets("1").Cells(Row, 1)
If i <> DateSerial(1900, 1, 0) Then
'DateSerial(1900, 1, 0) --> this is the default for no data in the field, i.e. i want to skip these
For x = 2 To 450
If Sheets("2").Cells(x, 2) = Sheets("1").Cells(Row, 1) Then
Sheets("2").Select
Cells(x, 1).Select
Selection.Copy
Sheets("1").Select
Cells(Row, 2).Select
ActiveSheet.Paste
End If
Next x
End If
Next Row
End Sub
Is good practice to avoid using variable names that are already representing something in code, i.e.: Row.
Row number should a be a integer/long type
You should declare and assign your worksheets to variables
Most code in VBA can be written without using .Select, though sometimes you might need it, this is not one of those times... and you should avoid at all cost using it in a nested loop. For ex:
Sheets("2").Select
Cells(x, 1).Select
Selection.Copy
Can be easily rewritten as such:
Sheets("2").Cells(x, 1).Copy
This might need some better logic, but based on your screenshots, it works:
Sub Macroturnip()
'
' Macroturnip Macro
'
Dim wsDst As Worksheet: Set wsDst = ActiveWorkbook.Sheets("1")
Dim lRowDst As Long: lRowDst = wsDst.Cells(wsDst.Rows.Count, 1).End(xlUp).Row
Dim wsSrc As Worksheet: Set wsSrc = ActiveWorkbook.Sheets("2")
Dim lRowSrc As Long: lRowSrc = wsSrc.Cells(wsSrc.Rows.Count, 1).End(xlUp).Row
Dim rngFind As Range
Dim Rs As Long, Rd As Long 'row is the row variable for the destination spreadsheet
For Rd = 2 To lRowDst
If wsDst.Cells(Rd, 1) <> "" Then
'DateSerial(1900, 1, 0) --> this is the default for no data in the field, i.e. i want to skip these
For Rs = 2 To lRowSrc
If wsDst.Cells(Rd, 1) = wsSrc.Cells(Rs, 2) Then
Set rngFind = wsDst.Range("B2:B" & Rd).Find(wsSrc.Cells(Rs, 1), Lookat:=xlWhole)
If rngFind Is Nothing Then
wsDst.Cells(Rd, 2) = wsSrc.Cells(Rs, 1).Value
Exit For 'No need to keep checking, move on
End If
Set rngFind = Nothing
End If
Next Rs
End If
Next Rd
End Sub
PS: I've assumed that by Sheets("2") you actually referred to a sheet named 2, and not Sheet2 or Sheets(2) which though look similar, are not the same thing.
Hello and first let me say thank you!
I use Excel to capture user requirements and descriptions. I then take that information and clean it up and paste into presentation docs, apply formatting, paste into Powerpoint, etc. It can be 100s of lines in total that this is done for. What I'm looking for is a macro that I can apply to data once it is pasted into Excel. The data will be text, non-numeric
I have a macro that I use to insert a blank row as every other row. I then do everything else manually (macro shown below).
What I'm looking for is a macro that inserts a blank row, then offsets Column 2 by 1 row down. then pastes column 1 into column 2(without copying the blank cells over my already existing data in column 2).
I've pasted a link to an image of what I'm looking for. I've also tried to show below (numbers are column 1, letters are column 2).
2 columns to 1 column - desired result
1 A 2 B3 C
Result I want:
1
A
2
B
3
C
My current "Blank Row" Macro:
Sub insertrow()
' insertrow Macro
Application.ScreenUpdating = True
Dim count As Integer
Dim X As Integer
For count = 1 To 300
If ActiveCell.Value <> "" Then
ActiveCell.Offset(1, 0).Select
Range(ActiveCell, ActiveCell.Offset(0, 0)).EntireRow.Insert
ActiveCell.Offset(1, 0).Select
For X = 1 To 1
Next X
Else
ActiveCell.Offset(1, 0).Range("a1").Select
End If
Next count
End Sub
This should work, but you'll have to adjust a little for your exact layout and needs.
Sub mergeColumns()
Dim mergedData As Variant
ReDim mergedData(1 To 600)
dataToProcess = Range("A2:B301")
For i = 1 To 300
mergedData(i * 2 - 1) = dataToProcess(i, 1)
mergedData(i * 2) = dataToProcess(i, 2)
Next i
Range("B2:B601") = WorksheetFunction.Transpose(mergedData)
End Sub
The following does what you need without inserting blank rows. It also calculates what the last row is on the sheet that has 2 columns so that you don't need to hard-code when the loop will end.
The comments should help you understand what is happening each step of the way. You can then modify this to work with your particular workbook. There are a lot of ways you could go about this. I chose to put the pivoted result on a second sheet.
Sub PivotTwoColumnsIntoOne()
Dim wb As Workbook
Dim src As Worksheet
Dim tgt As Worksheet
Dim rng As Range
Dim cell As Range
Dim lastRow As Long
Dim targetRow As Long
Set wb = ThisWorkbook
' set our source worksheet
Set src = wb.Sheets("Sheet1")
' set our target sheet (where the single column will be)
Set tgt = wb.Sheets("Sheet2")
' get the last row on our target sheet
lastRow = src.Range("A" & src.Rows.Count).End(xlUp).Row
' set the starting point for our target sheet
targetRow = 1
Set rng = src.Range("A1:A" & lastRow)
For Each cell In rng
With tgt.Range("A" & targetRow)
' get the value from the first column
.Value = cell.Value
' get the value from the second column
.Offset(1).Value = cell.Offset(, 1).Value
.HorizontalAlignment = xlLeft
End With
targetRow = targetRow + 2
Next cell
End Sub