VBA - Copy Range if cell not empty - excel

I currently have this code:
Sub createSheets(range_Copy As Range, range_Paste As Range)
'Copy the data
range_Copy.Copy
'Paste the data into the new worksheet
With range_Paste
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
End With
End Sub
...and this...
Call createSheets(Sheets("Export from QB - Annual Sales").Range("E:T"), Sheets("Sales - " & Sales_Date_Annual).Range("A1"))
It works great but what I actually want to do is... when copying the range E:T, I only want to copy the rows that do not have a blank value in column E... regardless if there is anything in the other columns.

I think below code will help you. Useful information here is, that you can reference a cell in a range using relative reference, i.e. Range("D4:E6").Cells(1, 1) is reference to cell D4. This way you can easily loop through given range.
Sub LoppthroughRange()
Dim i As Long, j As Long, rng As Range
Set rng = Range("E:T")
For i = 1 To rng.Rows.Count
If Not IsEmpty(rng.Cells(i, 1)) Then
For j = 1 To rng.Columns.Count
'copy all cells in a row
Next
End If
Next
End Sub
Putting it all together, you should use:
Sub createSheets(range_Copy As Range, range_Paste As Range)
Dim i As Long, j As Long, k As Long
k = 1
For i = 1 To range_Copy.Rows.Count
If Not IsEmpty(range_Copy.Cells(i, 1)) Then
With range_Copy
.Range(Cells(i, 1), Cells(i, .Columns.Count)).Copy
End With
With range_Paste
.Range(Cells(k, 1), Cells(k, .Columns.Count)).PasteSpecial xlValues
.Range(Cells(k, 1), Cells(k, .Columns.Count)).PasteSpecial xlFormats
End With
k = k + 1
End If
Next
End Sub

Related

in the range A1 to A70, if a cell is empty/blank then delete that entire row and move the other rows underneath up

in the range A1 to A70, if a cell is empty/blank then delete that entire row and move the other rows underneath up
Thank you
Use following codes.
Sub RemoveDuplicate()
On Error Resume Next
Range("A1:A70").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End Sub
Edit:
Sub RemoveBlankRowsInARange()
Dim rng As Range, rws As Long, i As Long
Dim LastRow As Long
' LastRow = Cells(Rows.Count, "A").End(xlUp).Row
' Set rng = ActiveSheet.Range("A2:A" & LastRow)
' rws = rng.Rows.Count
'
' For i = rws To 1 Step (-1)
For i = 100 To 1 Step (-1)
If WorksheetFunction.CountA(Rows(i)) = 0 Then Rows(i).EntireRow.Delete
Next
End Sub
#Harun24HR - Here's how I attempted at solving this problem: I recorded a macro that deletes a row and I edited that macro to do my original question, why doesn't this work, please correct it:
Sub DeleteRowWithEmptyCell()
Dim row As Integer
For row = 1 To 100 'or whatever numbers needed
If Cells(row, 1).Value() = "" Then
Rows("row:row").Select
Selection.Delete Shift:=xlUp
End If
Next row
End Sub

Need help to optimize the Excel VBA code that aggregates duplicates

Below is my source table
Name Sales
---------------------------------
Thomas 100
Jay 200
Thomas 100
Mathew 50
Output I need is as below
Name Sales
---------------------------------
Thomas 200
Jay 200
Mathew 50
Basically, I have 2 columns that can have duplicates and I need to aggregate the second column based on first column.
Current code I have is as below. Its working perfectly fine. It takes around 45 seconds to run for 4500 records. I was wondering if there is a more efficient way to do this... as it seems to be a trivial requirement.
'Combine duplicate rows and sum values
Dim Rng As Range
Dim LngRow As Long, i As Long
LngLastRow = lRow 'The last row is calculated somewhere above...
'Initializing the first row
i = 1
'Looping until blank cell is encountered in first column
While Not Cells(i, 1).Value = ""
'Initializing range object
Set Rng = Cells(i, 1)
'Looping from last row to specified first row
For LngRow = LngLastRow To (i + 1) Step -1
'Checking whether value in the cell is equal to specified cell
If Cells(LngRow, 1).Value = Rng.Value Then
Rng.Offset(0, 1).Value = Rng.Offset(0, 1).Value + Cells(LngRow, 2).Value
Rows(LngRow).Delete
End If
Next LngRow
i = i + 1
Wend
Note that this is part of a larger excel app and hence I definitely need the solution to be in Excel VBA.
Here you go:
Option Explicit
Sub Consolidate()
Dim arrData As Variant
Dim i As Long
Dim Sales As New Scripting.Dictionary 'You will need the library Microsoft Scripting Runtime
Application.ScreenUpdating = False 'speed up the code since excel won't show you what is happening
'First of all, working on arrays always speeds up a lot the code because you are working on memory
'instead of working with the sheets
With ThisWorkbook.Sheets("YourSheet") 'change this
i = .Cells(.Rows.Count, 1).End(xlUp).Row 'last row on column A
arrData = .Range("A2", .Cells(i, 2)).Value 'here im assuming your row 1 has headers and we are storing the data into an array
End With
'Then we create a dictionary with the data
For i = 1 To UBound(arrData) 'from row 2 to the last on Q1 (the highest)
If Not Sales.Exists(arrData(i, 1)) Then
Sales.Add arrData(i, 1), arrData(i, 2) 'We add the worker(Key) with his sales(Item)
Else
Sales(arrData(i, 1)) = Sales(arrData(i, 1)) + arrData(i, 2) 'if the worker already exists, sum his sales
End If
Next i
'Now you have all the workers just once
'If you want to delete column A and B and just leave the consolidate data:
With ThisWorkbook.Sheets("YourSheet") 'change this
i = .Cells(.Rows.Count, 1).End(xlUp).Row 'last row on column A
.Range("A2:B" & i).ClearContents
.Cells(2, 1).Resize(Sales.Count) = Application.Transpose(Sales.Keys) 'workers
.Cells(2, 2).Resize(Sales.Count) = Application.Transpose(Sales.Items) 'Their sales
End With
Application.ScreenUpdating = True 'return excel to normal
End Sub
To learn everything about dictionaries (and more) check this
With data in cols A and B like:
Running this short macro:
Sub KopyII()
Dim cell As Range, N As Long
Columns("A:A").Copy Range("C1")
ActiveSheet.Range("C:C").RemoveDuplicates Columns:=1, Header:=xlNo
N = Cells(Rows.Count, "C").End(xlUp).Row
Range("B1").Copy Range("D1")
Range("D2:D" & N).Formula = "=SUMPRODUCT(--(A:A= C2),(B:B))"
End Sub
will produce this in cols C and D:
NOTE:
This relies on Excel's builtin RemoveDuplicates feature.
EDIT#1:
As chris neilsen points out, this function should be a bit quicker to evaluate:
Sub KopyIII()
Dim cell As Range, N As Long, A As Range, C As Range
Set A = Range("A:A")
Set C = Range("C:C")
A.Copy C
C.RemoveDuplicates Columns:=1, Header:=xlNo
N = Cells(Rows.Count, "C").End(xlUp).Row
Range("B1").Copy Range("D1") ' the header
Range("D2:D" & N).Formula = "=SUMIFS(B:B,A:A,C2)"
End Sub

Macro to copy cells four rows apart without using select

This code copies the entries from Sheet1!A2, Sheet1!B2, etc. and pastes them onto Sheet2 with 3 rows between each entry. I want to duplicate this code without using .select.
Option Explicit
Sub Copy_Paste()
Dim i As Integer
For i = 1 To 100
Sheets("Sheet1").Select
Range("A2,B2,C2,D2,E2").Select
ActiveCell.Range(Cells(i, 1), Cells(i, 2)).Select
Selection.Copy
Sheets("Sheet2").Select
Cells(((i - 1) * 4) + 1, 1).Select
ActiveSheet.Paste
Next i
End Sub
This is what I have so far, but it is not working.
Option Explicit
Sub Copy_Paste()
Dim i As Integer
For i = 1 To 100
Dim ws1 As Worksheet, rng As Range, act As Range
Set ws1 = Worksheets("Data")
Set rng = ActiveSheet.Range("A2,B2,C2,D2,E2")
Set act = ActiveCell.Range(Cells(i, 1), Cells(i, 2))
Selection.Copy
Dim ws2 As Worksheet, rng2 As Range
Set ws2 = Worksheets("Calculate")
Set rng2 = Cells(((i - 1) * 4) + 1, 1)
ActiveSheet.Paste
Next i
End Sub
I used this type of operation in one of my vba codes:
'do copy from reference "Answers_Source" worksheet
wb.Sheets("Answers_Source").Range("h1:z160").Copy
'now paste the formulas into the student exam workbook
wb2.Sheets("Answers").Range("h1:z160").Paste
So you can edit that to your situation.
you could use Offset() property of Range object
Sub Copy_Paste()
Dim i As Long
For i = 1 To 100
Sheets("Sheet1").Range("A2,B2").Offset(i - 1).Copy Destination:=Sheets("Sheet2").Range("A1:B1").Offset((i - 1) * 4)
Next
End Sub
while if you only need paste values, then it's quicker:
Sub Copy_Paste_Values()
Dim i As Long
For i = 1 To 100
Sheets("Sheet2").Range("A1:B1").Offset((i - 1) * 4).Value = Sheets("Sheet1").Range("A2,B2").Offset(i - 1).Value
Next
End Sub
You know you can just say something like "Range x values = Range y values":
ws2.Range("A1:B4").Value = ws1.Range("A1:B4").Value
If you can define your ranges using Range(Cells(1,1), Cells(4,2)) then I'm pretty sure you can do everything you want in one line

Copy every two cells and transpose

I am trying to transpose every next two cells and paste them in next right cells.
I have a table as shown in the screenshot:
I want to copy range "B2:B3" and transpose this to "C2" and then loop until there is some data in column B. (so select and copy next "B4:B5" and transpose this to "B4").
I cannot get this to transpose in the right place and then loop.
I have something like this (I did not add loop yet to this macro):
Sub Macro1()
Dim a As Long, b As Long
a = ActiveCell.Column
b = ActiveCell.Row
Range("B2").Select
Range(ActiveCell, Cells(b + 1, a)).Select
Selection.Copy
End Sub
a VBA solution
Option Explicit
Sub main()
Dim pasteRng As Range
Dim i As Long
With ActiveSheet
Set pasteRng = .Range("C1:D2")
With .Range("B2:B" & .Cells(.Rows.count, "B").End(xlUp).Row)
For i = 1 To .Rows.count Step 2
pasteRng.Offset(i).Value = Application.Transpose(.Cells(i, 1).Resize(2))
Next i
End With
End With
End Sub
No VBA is needed. In C2 enter:
=INDEX(B:B,ROUNDUP(ROWS($1:1)/2,0)*2)
and copy down and in D2 enter:
=INDEX(B:B,ROUNDUP(ROWS($1:1)/2,0)*2+1)
and copy down:
and if you need this as part of some VBA effort:
Sub dural()
Dim i As Long
Dim r1 As Range, r2 As Range
For i = 2 To 10 Step 2
Set r1 = Range("B" & i & ":B" & (i + 1))
Set r2 = Range("C" & i)
r1.Copy
r2.PasteSpecial Transpose:=True
r2.Offset(1, 0).PasteSpecial Transpose:=True
Next i
End Sub

VBA paste range

I would like to copy a range and paste it into another spreadsheet. The following code below gets the copies, but does not paste:
Sub Normalize()
Dim Ticker As Range
Sheets("Sheet1").Activate
Set Ticker = Range(Cells(2, 1), Cells(65, 1))
Ticker.Copy
Sheets("Sheet2").Select
Cells(1, 1).Activate
Ticker.PasteSpecial xlPasteAll
End Sub
How can I paste the copies into another sheet?
To literally fix your example you would use this:
Sub Normalize()
Dim Ticker As Range
Sheets("Sheet1").Activate
Set Ticker = Range(Cells(2, 1), Cells(65, 1))
Ticker.Copy
Sheets("Sheet2").Select
Cells(1, 1).PasteSpecial xlPasteAll
End Sub
To Make slight improvments on it would be to get rid of the Select and Activates:
Sub Normalize()
With Sheets("Sheet1")
.Range(.Cells(2, 1), .Cells(65, 1)).Copy Sheets("Sheet2").Cells(1, 1)
End With
End Sub
but using the clipboard takes time and resources so the best way would be to avoid a copy and paste and just set the values equal to what you want.
Sub Normalize()
Dim CopyFrom As Range
Set CopyFrom = Sheets("Sheet1").Range("A2", [A65])
Sheets("Sheet2").Range("A1").Resize(CopyFrom.Rows.Count).Value = CopyFrom.Value
End Sub
To define the CopyFrom you can use anything you want to define the range, You could use Range("A2:A65"), Range("A2",[A65]), Range("A2", "A65") all would be valid entries. also if the A2:A65 Will never change the code could be further simplified to:
Sub Normalize()
Sheets("Sheet2").Range("A1:A65").Value = Sheets("Sheet1").Range("A2:A66").Value
End Sub
I added the Copy from range, and the Resize property to make it slightly more dynamic in case you had other ranges you wanted to use in the future.
I would try
Sheets("Sheet1").Activate
Set Ticker = Range(Cells(2, 1), Cells(65, 1))
Ticker.Copy
Worksheets("Sheet2").Range("A1").Offset(0,0).Cells.Select
Worksheets("Sheet2").paste
This is what I came up to when trying to copy-paste excel ranges with it's sizes and cell groups. It might be a little too specific for my problem but...:
'**
'Copies a table from one place to another
'TargetRange: where to put the new LayoutTable
'typee: If it is an Instalation Layout table(1) or Package Layout table(2)
'**
Sub CopyLayout(TargetRange As Range, typee As Integer)
Application.ScreenUpdating = False
Dim ncolumn As Integer
Dim nrow As Integer
SheetLayout.Activate
If (typee = 1) Then 'is installation
Range("installationlayout").Copy Destination:=TargetRange '#SHEET2 TEM DE PASSAR A SER A SHEET DO PROJECT PLAN!#####
ElseIf (typee = 2) Then 'is package
Range("PackageLayout").Copy Destination:=TargetRange '#SHEET2 TEM DE PASSAR A SER A SHEET DO PROJECT PLAN!#####
End If
Sheet2.Select 'SHEET2 TEM DE PASSAR A SER A SHEET DO PROJECT PLAN!#####
If typee = 1 Then
nrow = SheetLayout.Range("installationlayout").Rows.Count
ncolumn = SheetLayout.Range("installationlayout").Columns.Count
Call RowHeightCorrector(SheetLayout.Range("installationlayout"), TargetRange.CurrentRegion, typee, nrow, ncolumn)
ElseIf typee = 2 Then
nrow = SheetLayout.Range("PackageLayout").Rows.Count
ncolumn = SheetLayout.Range("PackageLayout").Columns.Count
Call RowHeightCorrector(SheetLayout.Range("PackageLayout"), TargetRange.CurrentRegion, typee, nrow, ncolumn)
End If
Range("A1").Select 'Deselect the created table
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
'**
'Receives the Pasted Table Range and rearranjes it's properties
'accordingly to the original CopiedTable
'typee: If it is an Instalation Layout table(1) or Package Layout table(2)
'**
Function RowHeightCorrector(CopiedTable As Range, PastedTable As Range, typee As Integer, RowCount As Integer, ColumnCount As Integer)
Dim R As Long, C As Long
For R = 1 To RowCount
PastedTable.Rows(R).RowHeight = CopiedTable.CurrentRegion.Rows(R).RowHeight
If R >= 2 And R < RowCount Then
PastedTable.Rows(R).Group 'Main group of the table
End If
If R = 2 Then
PastedTable.Rows(R).Group 'both type of tables have a grouped section at relative position "2" of Rows
ElseIf (R = 4 And typee = 1) Then
PastedTable.Rows(R).Group 'If it is an installation materials table, it has two grouped sections...
End If
Next R
For C = 1 To ColumnCount
PastedTable.Columns(C).ColumnWidth = CopiedTable.CurrentRegion.Columns(C).ColumnWidth
Next C
End Function
Sub test ()
Call CopyLayout(Sheet2.Range("A18"), 2)
end sub
You can do something like below to paste values in other ranges. (faster than copying and pasting values)
ThisWorkbook.WorkSheets("Sheet2").Range("A1:A2").Value = Sheets`("Sheet1").Range("A1:A2").Value

Resources