my goal is to copy cells in a dynamic range from Column B to S to another sheet if they are non zero. Additionally, would like to move the cells up to the top of the next sheet (Without having to clear blank rows each time). Have the code working for 1 column (when Col was replaced with "B", "C", etc.) but when I tried to make it a for loop of multiple it doesnt work.
Any help would be appreciated!
Sub MoveFormulaDataLooped()
Dim ws1 As Worksheet: Set ws1 = Worksheets("Fancy Wall")
Dim ws2 As Worksheet: Set ws2 = Worksheets("Sheet1")
Dim VeryLastRow As Integer: VeryLastRow = ws1.Cells(ws1.Rows.Count, 1).End(xlUp).Row
Dim i As Integer
Dim Col As Integer
For i = 2 To VeryLastRow
For Col = 2 To 19
If ws1.Range(Col & i) > 0 Then
ws2.Range(Col & i) = ws1.Range(Col & i)
Next
Next
End Sub
A few notes:
You are looking for the property .Cells instead of .Range, as it uses row and column index to access your range.
You are missing an End If in you most inner conditional
You need to capture the next row for your ws2 so that you don't have blanks between them
I included a function that helps you find the next available row, and made the fixes from my notes above.
' Finds the next empty row on a worksheet.
Public Function NextAvailibleRow(ByRef ws As Worksheet) As Range
On Error GoTo catch
Set NextAvailibleRow = ws.Cells.Find("*", , xlValues, , xlRows, xlPrevious).Offset(1).EntireRow
Exit Function
' If there is an error, that means the worksheet is empty.
' Return the first row
catch:
Set NextAvailibleRow = ws.Rows(1)
End Function
Sub MoveFormulaDataLooped()
Dim ws1 As Worksheet: Set ws1 = Worksheets("Fancy Wall")
Dim ws2 As Worksheet: Set ws2 = Worksheets("Sheet1")
Dim VeryLastRow As Integer
VeryLastRow = ws1.Cells(ws1.Rows.Count, 1).End(xlUp).Row
Dim i As Integer
For i = 2 To VeryLastRow
' Need to capture the next row for Sheet1
Dim nextSheet1Row As Long
nextSheet1Row = NextAvailibleRow(ws2).Row
Dim Col As Integer
For Col = 2 To 19
If ws1.Cells(i, Col) > 0 Then
' Use `.Cells`
ws2.Cells(nextSheet1Row, Col) = ws1.Cells(i, Col)
End If ' Was missing
Next
Next
End Sub
Related
i have a big datasheet and i need a code to scan a column( screenshot "selection") for a x or add a checkbox. If there is a x the row should be selected and some of the columns should be transposed into a new table.
i have an code to scan the column for x and have the code to transpose the columns i need but i need some help to combine these codes together.
scan column(selection) for an x and select the rows
transpose some cells(selected colums) of the selected row into a new table ( i have the code)
For Each c In Range("K:K")
' If c.Value = "x" Then
' MsgBox "x found at " & c.Address
'End If
'Next c
Sub TransposeColumn2Row()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim Myarray() As Variant
Dim LastRow As Integer, LastColumn As Integer
Dim StartCell As Range
Set ws1 = ThisWorkbook.Sheets("Sheet1")
Set ws2 = ThisWorkbook.Sheets("Sheet2")
Dim i As Long
Dim j As Long
Set StartCell = ws1.Range("A1")
LastRow = ws1.Cells(ws1.Rows.Count, StartCell.Column).End(xlUp).Row
LastColumn = ws1.Cells(StartCell.Row, ws1.Columns.Count).End(xlToLeft).Column
'copy specific columns into worksheet 2
j = 1
For i = 1 To LastColumn Step 1
Select Case i
Case 1, 4, 8, 6, 9, 3, 5 'target columns to copy
With ws1
Myarray() = .Range(.Cells(1, i), .Cells(LastRow, i)).Value
End With
With ws2
.Range(.Cells(j, 1), .Cells(j, LastRow)) = Application.WorksheetFunction.Transpose(Myarray())
End With
j = j + 1
Case Else
End Select
Next i
Erase Myarray()
End Sub
Help me combine these codes
Thx in advance
If this is a one-time task, I would use a formula:
=TRANSPOSE(FILTER(FILTER(A:J, {1,0,1,1,1,1,0,1,1,0}), K:K="x"))
The exact notation depends on local settings (the formula looks different in my case). But this one can be used with Evaluate in VBA. Here we mark columns to copy with an array {1,0,1,1,1,1,0,1,1,0} and then filter the rows with "x" in the column K.
As for VBA, this case would be easier to solve with ListObject in general case. But we can also Intersect columns of interest with marked rows and .Copy toDestination:
Sub CopyMarked()
Dim Source As Worksheet
Dim Destination As Worksheet
Dim Data As Range
Dim Criteria As Range
Set Source = ActiveSheet
Set Destination = Worksheets.Add(After:=Source)
Set Data = Source.Range("A:A, C:F, H:I") ' columns 1,4,8,6,9,3,5
Set Criteria = Source.Columns("K").SpecialCells(xlCellTypeConstants).EntireRow
Intersect(Data, Criteria).Copy
Destination.Range("a1").PasteSpecial xlPasteValues, Transpose:=True
End Sub
Hi I previously posted about some difficulties in running a loop. I made some adjustments to it. I am wondering what is wrong.
Sub Macro1()
Dim DVariable As Date
Dim RngFind As Range
Dim MonthNo, YearNo As Integer
Dim StartDate, EndDate As Date
Dim PasteCell As Range
Dim M As Long, i As Long
Dim ws As Worksheet
Dim ws1 As Worksheet
Application.DisplayAlerts = False
Sheets("By Trader").Select
Set ws1 = ThisWorkbook.Sheets.Add(After:= _
ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
ws1.Name = "NEW"
Set ws = Sheets("Macro")
Sheets("Macro").Select
M = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
For M = 2 To M
With Sheets("By Trader")
'loop column N until last cell with value (not entire column)
For Each Cell In .Range("N1:N" & .Cells(.Rows.Count, "N").End(xlUp).Row)
If Cell.Value = M Then
' Copy>>Paste in 1-line (no need to use Select)
.Rows(Cell.Row).Copy Destination:=Sheets("NEW").Rows(Cell.Row)
End If
Next M
Application.DisplayAlerts = True
End Sub
I am aiming to extract the entire row if there is a match in values to another sheet.
You are missing a Next Cell and an End With
Sub Macro1()
Dim DVariable As Date
Dim RngFind As Range
' You need to declare every variable in the line. If you don't it will be declared as a variant instead of just your last declaration
Dim MonthNo As Integer, YearNo As Integer
Dim StartDate, EndDate As Date
Dim PasteCell As Range
Dim M As Long, i As Long, NoRow As Long
Dim ws As Worksheet
Dim ws1 As Worksheet
Application.DisplayAlerts = False
Sheets("By Trader").Select
Set ws1 = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
ws1.Name = "NEW"
Set ws = Sheets("Macro")
ws.Select
' Changed variable to prevent erroneous errors
NoRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
For M = 2 To NoRow
With Sheets("By Trader")
'loop column N until last cell with value (not entire column)
For Each Cell In .Range("N1:N" & .Cells(.Rows.Count, "N").End(xlUp).Row)
If Cell.Value = M Then
' Copy>>Paste in 1-line (no need to use Select)
.Rows(Cell.Row).Copy Destination:=Sheets("NEW").Rows(Cell.Row)
End If
' Missing the next two lines
Next Cell
End With
Next M
Application.DisplayAlerts = True
End Sub
I'm trying to compare sheet1 "A" column values to sheet2 "E:E" column values and copy/paste the whole line of every match to sheet3. Please help me to complete this task. I'm very new to VBA.
Thank you very much in advance!
Sub DelDups_TwoLists()
Dim iListCount As Integer
Dim iCtr As Integer
' Turn off screen updating to speed up macro.
Application.ScreenUpdating = False
' Get count of records to search through (list that will be deleted).
iListCount = Sheets("sheet1").Cells(Rows.Count, "A").End(xlUp).Row
' Loop through the "master" list.
For Each x In Sheets("Sheet2").Range("E:E" & Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Row)
' Loop through all records in the second list.
For iCtr = iListCount To 1 Step -1
' Do comparison of next record.
' To specify a different column, change 1 to the column number.
If x.Value = Sheets("Sheet1").Cells(iCtr, 1).Value Then
' If match is true then delete row.
Sheets("Sheet1").Cells(iCtr, 1).EntireRow.Copy
Sheets("Sheet3").Select.Paste
End If
Next iCtr
Next
Application.ScreenUpdating = True
MsgBox "Done!"
End Sub
Sub DelDupsTwoLists()
Dim lastRowWs1 As Long, lastRowWs2 As Long
Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
Set ws1 = Worksheets(1)
Set ws2 = Worksheets(2)
Set ws3 = Worksheets(3)
lastRowWs1 = LastRow(ws1.Name, 1)
lastRowWs2 = LastRow(ws2.Name, 5) 'E = 5
Dim myCell1 As Range, myCell2 As Range
Dim ws1Range As Range, ws2Range As Range
Set ws1Range = ws1.Range(ws1.Cells(1, "A"), ws1.Cells(lastRowWs1, 1))
Set ws2Range = ws2.Range(ws2.Cells(1, "E"), ws2.Cells(lastRowWs2, 1))
Dim rangeToDelete As Range
For Each myCell1 In ws1Range
For Each myCell2 In ws2Range
If myCell1.Value = myCell2.Value Then
Dim lastRowWs3: lastRowWs3 = LastRow(ws3.Name, 1) + 1
myCell2.EntireRow.Copy Destination:=ws3.Cells(lastRowWs3, 1)
If Not rangeToDelete Is Nothing Then
Set rangeToDelete = Union(rangeToDelete, myCell2.EntireRow)
Else
Set rangeToDelete = myCell2.EntireRow
End If
End If
Next
Next
If Not rangeToDelete Is Nothing Then
Debug.Print "Deleting rangeToDelete - "; rangeToDelete.Address
rangeToDelete.Delete
End If
Debug.Print "Done!"
End Sub
Public Function LastRow(wsName As String, Optional columnToCheck As Long = 1) As Long
Dim ws As Worksheet
Set ws = Worksheets(wsName)
LastRow = ws.Cells(ws.Rows.Count, columnToCheck).End(xlUp).Row
End Function
Pretty much I rewrote the whole code from scratch. It pretty much uses the initial n2 complexity, but is rather faster than that, because the deletion of the rows in WorkSheet(2) is done in a single last step rangeToDelete.Delete, which saves a lot of time.
Pretty much, the code defines 2 ranges with which is works - ws1Range and ws2Range, using the LastRow function. Once it defines them, it starts looping through them and comparing them. Hence the n2 complexity. In case of equal values, the row is copied and the cell is added to the rangeToDelete.
Note - it will probably not work as "out of the box solution", but try to debug further with F8 and see what happens.
Additionally:
Using Integer is not a great idea in VBA.
"_" in the Sub name is used for Events in VBA, thus it is not a great idea to use it. (although it works)
How to avoid using Select in Excel VBA
Give this a try (see comments in code for more details):
Sub DelDups_TwoLists()
' Turn off screen updating to speed up macro.
Application.ScreenUpdating = False
With ActiveWorkbook
Dim wsSrc As Worksheet: Set wsSrc = .Sheets("Sheet1") 'declare and set the source worksheet
Dim wsDst As Worksheet: Set wsDst = .Sheets("Sheet3") 'declare and set the destination worksheet
Dim R1 As Long, R2 As Long, C As Long, lRow As Long, lCol As Long 'declare variables to use
With wsSrc
lCol = .Cells(1, Columns.Count).End(xlToLeft).Column 'get the last column value in the source sheet, at row 1, will reuse this laster
Dim arrData_1 As Variant: arrData_1 = .Range(.Cells(1, 1), .Cells(.Cells(Rows.Count, 1).End(xlUp).Row, 1)) 'declare and allocate the source data to an array
End With
With .Sheets("Sheet2")
Dim arrData_2 As Variant: arrData_2 = .Range("E1:E" & .Cells(Rows.Count, 1).End(xlUp).Row) 'declare and allocate the compare data to an array
End With
End With
With wsDst
For R1 = LBound(arrData_1) To UBound(arrData_1) 'for each row in the source data
For R2 = LBound(arrData_2) To UBound(arrData_2) 'for each row in the compare data
If arrData_1(R1, 2) = arrData_2(R2, 1) Then 'if there is a match
lRow = .Cells(Rows.Count, 1).End(xlUp).Row + 1 'get the last row in the destination sheet
.Range(.Cells(lRow, 1), .Cells(lRow, lCol)).Value = _
wsSrc.Range(wsSrc.Cells(R1, 1), wsSrc.Cells(R1, lCol)).Value 'allocate the matching values
Exit For 'exit early here if there is a match, go to next row to check
End If
Next R2
Next R1
End With
Application.ScreenUpdating = True
MsgBox "Done!"
End Sub
I want to transfer data from one sheet to another.
My sheet1 is "form" type sheet. I have command button in it.
On pressing of command button cell value should be copied to another Sheet2.
I want every copy of value should be in one row and fixed column.
It should not be overwrite but enter in next empty row.
I am using below VBA code:
Private Sub Button1_Click()
Dim rng As Range
Set rng = Sheets("Sheet1").Range("A1,A2,B1,B2,B3")
For Each cell In rng
'here you copy to another sheet, one row lower
Sheets("Sheet2").Cells(cell.Row + 1, cell.Column).Value = cell.Value
Next cell
For x = lRow To 2 Step -1
If Range("I" & x) <> vbNullString Then Range("I" & x).EntireRow.Delete
Next x
Application.CutCopyMode = False
End Sub
Option Explicit
Sub test()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim LastRow As Long, i As Long
Dim str As String, chara As Variant
Dim rng As Range, cell As Range
With ThisWorkbook
Set ws1 = .Worksheets("Sheet1") '<- Set worksheet ws1
Set ws2 = .Worksheets("Sheet2") '<- Set worksheet ws2
End With
Set rng = ws1.Range("B1:D1,B2:B6,B8:E11") '<- Set the range you want to loop
For Each cell In rng
If str = "" Then '<- Create a string with all details
Else
str = str & "," & cell.Value
End If
Next cell
LastRow = ws2.Cells(ws2.Rows.Count, "A").End(xlUp).Row
i = 1
For Each chara In Split(str, ",") '<- Split with commas
ws2.Cells(LastRow + 1, i) = chara
i = i + 1
Next chara
End Sub
I'm finishing a script that verifies if a cell in Column A of Sheet1 ("INCIDENTS") is duplicated at Column A of Sheet2 ("INCDB") and if the cell is duplicate it deletes the whole row in Sheet1.
The problem is that after the first loop (and deleting the row) it gives me the 424 error and highlights If iSrc.Cells.Value = iDst.Cells.Value Then
Any ideas on the cause? Here's the code:
Sub CTDeleteDuplicatePaste()
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim iSrc As Variant
Dim iDst As Variant
Dim rng As Range
Set ws1 = Sheets("INCIDENTS")
Set ws2 = Sheets("INCDB")
For Each iSrc In ws1.Range("A5:A9999" & LastRow)
For Each iDst In ws2.Range("A5:A9999")
If iSrc.Cells.Value = iDst.Cells.Value Then
If rng Is Nothing Then
Set rng = iSrc.EntireRow
Else
Set rng = Union(rng, iSrc.EntireRow)
End If
rng.EntireRow.Delete
End If
Next iDst
Next iSrc
End Sub
I'd do it without objects iSrc and iDst. And from reverse order - this code worked for me:
Sub CTDeleteDuplicatePaste()
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim i As Long
Dim j As Long
Set ws1 = Sheets("INCIDENTS")
Set ws2 = Sheets("INCDB")
For i = 9 To 5 Step -1 'change 9 to 9999 for your real data
For j = 9 To 5 Step -1 'change 9 to 9999 for your real data
If Len(ws1.Cells(i, 1).Value) > 0 Then
If ws1.Cells(i, 1).Value = ws2.Cells(j, 1).Value Then
ws1.Cells(i, 1).EntireRow.Delete
GoTo nextIteration
End If
End If
Next
nextIteration:
Next
End Sub
Regarding the performance issue of .EntireRow.Delete, this is the additional reading:
Tests on processing 1 million rows
Solution employing Sorting