Copying excel row from one sheet to another - vba

I am copying data from one sheet to another, from source range(Q5:AIxxx) to destination range(C6:Uxxx)
My VBA code starts with a cell and loops to the end of the column to finish copying that column's data:
Set s = Worksheets("Source")
Set d = Worksheets("Destination")
Dim i As Integer, j As Integer
j = 6
For i = 5 To 1500
If s.Cells(i, 1).Value = "a" Or s.Cells(i, 1).Value = "b" Then
d.Cells(j, 3).Value = s.Cells(i, 17).Value
j = j + 1
End If
Next i
I have > 20 columns to move, is there a way I can copy the row at once? something like this:
d.Cells(j, 3:21).Value = s.Cells(i, 17:35).Value
At the moment, I'm having to specify each column:
d.Cells(j, 3).Value = s.Cells(i, 17).Value 'column 1
d.Cells(j, 4).Value = s.Cells(i, 18).Value 'column 2
d.Cells(j, 5).Value = s.Cells(i, 19).Value 'column 3
etc

You can do it by
d.range(d.cells(j,3), d.cells(j,21)).copy
s.range(s.cells(i,17), s.cells(i,35)).pastespecial xlvalues

You can use:
.Range(<your_range>).copy
For example do:
Activesheet.Range("A1:B10").Copy
and thenjust paste anywhere you want with .Paste
ActiveSheet.Paste Destination:=Worksheets(2).Range("D1:D5")
It's a build in function in vba.
See here also for copying Range:
https://msdn.microsoft.com/en-us/library/office/ff837760.aspx
And for Paste:
https://msdn.microsoft.com/en-us/library/office/ff821951.aspx

Using ranges instead can make it a bit easier:
Dim s As Range, d As Range
Set d = Worksheets("Destination").Cells(6, 15) ' notice the column 15
For Each s in Worksheets("Source").Range("A5:A1500")
If s = "a" Or s = "b" Then
d(,3) = s(,3)
d(,4) = s(,4)
' or d(,3).Resize(,19) = s(,3).Resize(,19) ' .Value optional
Set d = d.Offset(1) ' move to next row
End If
Next
There are easier ways to do that without VBA. For example Power Query, PivotTable, Copy Link and Table Filter, Data tab > From Access, etc.

Related

I can not "pich" the dates e "put" in other sheet! (copy and paste)

I prefer to use the function .value, because i dont miss anything, but i cant to paste or the all range
Anyone know how i can do?
Sub AUTO()
Application.ScreenUpdating = False
'sheet that i want paste
PasteData1 = ActiveSheet.Cells(3, 6).Value
DATAAUTO = "L:\ANALISTA_M\Frade\FINANCIAL SERVICES\INSURANCE\Mercado\SUSEP\Planilhas\Auto-Susep.xlsx"
Workbooks.Open (DATAAUTO)
sName = ActiveSheet.Name
'count the number of rows and columns
i = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row - 11
c = ActiveSheet.Cells(6, Columns.Count).End(xlToLeft).Column
'select all range that i want
COPYDATE = ActiveSheet.Range(Cells(6, 1), Cells(i, c)).Value
PASTEAUTO = "L:\ANALISTA_M\Frade\FINANCIAL SERVICES\INSURANCE\Mercado\SUSEP\Auto.xlsm"
Workbooks.Open (PASTEAUTO)
Worksheets(PasteData1).Activate
'the problem is here!!! i need to respect a order the beging my paste
ActiveSheet.Cells(2, 2).Value = COPYDATE
ActiveSheet.Range(Cells(2, 2), Cells(i - 4, c + 1)).Replace What:=".", Replacement:=""
ActiveSheet.Range(Cells(2, 2), Cells(i - 4, c + 1)).Replace What:=",", Replacement:="."
Worksheets("Consolidado").Activate
Workbooks("Auto-Susep.xlsx").Close
Application.ScreenUpdating = True
End Sub
to use the .Value over copy paste you need to have the same size range. You have one cell trying to hold a 2 dimensional array.
So change:
ActiveSheet.Cells(2, 2).Value = COPYDATE
to:
ActiveSheet.Cells(2, 2).Resize(UBound(COPYDATE,1),UBound(COPYDATE,2)).Value = COPYDATE
Also I do not see where you declare any of your variables, that is a bad habit, one should always declare their variables even if they are of a Variant type.
Dim COPYDATE() as Variant

How to fill up empty lines in Excel Table with one existing value?

I have an Excel Table, with some columns. But at the moment a have a problem with column Duration.
When I scrolled down the table, i have unexpectedly noticed, that many IDs have empty lines, and only one line of this ID has an actual value.
Is it possible to fill up other empthy lines with this only one existing value using VBA? That means, that all empty values for ID6979960 should be filled up with a value 42:15:56, and so on.
Without that, my other calculations in my table, don't work properly.
I don't know exactly how copying of values works in VBA.
Public Sub FillEmpty()
Dim finded As Range
Dim Sheet As Worksheet
Set Sheet = ActiveSheet 'or any other sheet -> .Sheets("")
With Sheet
lastrow = .Cells(1, 1).End(xlDown).Row
For i = 1 To lastrow
If StrComp(.Cells(i, 2).Value, "") = 0 Then
Set finded = .Columns(2).Find("*", after:=.Cells(i, 2), LookIn:=xlValues)
ID = .Cells(finded.Row, 1).Value
Filler = .Cells(finded.Row, 2).Text
Else
ID = .Cells(i, 1).Value
Filler = .Cells(i, 2).Text
End If
Index = i
While ID = .Cells(Index, 1).Value
.Cells(Index, 2).Value = Filler
Index = Index + 1
Wend
Next i
End With
End Sub
Made it real quick so not the most optimal solution. I tested it with your example and it works. Not sure with many more rows. Check it and let me know if it works for you.
Sub fillerv2()
rowscnt = 1000
tmi = 1
tm = ""
For i = 1 To rowscnt
If tm <> Cells(i, 1).Value Then
For o = tmi To i - 1
If IsEmpty(Cells(o, 2).Value) = False Then
Pattern = Cells(o, 2).Value
Exit For
End If
Next o
For o = tmi To i - 1
Cells(o, 2).Value = Pattern
Next o
tm = Cells(i, 1).Value
tmi = i
End If
Next i

Excel Macro Transpose only few columns

I have a excel sheet looks like this: "Sheet1" & "Sheet2" and I wanted the result as shown in "Sheet3".
Sample Data
Eventually I would like to put a "Button" in a separate sheet (Control Panel) and when clicking on it I need to combine the data from "Sheet1" and "Sheet2" with the transpose effect as shown in "Sheet3".
How can I automate this using macro since there are ~2000 "rows" in Sheet 1 and ~1000 in Sheet 2. I'm new to macro so hopefully I can make this automated otherwise I'm copying and pasting all of them manually.
Thanks!
It might be helpful to use a function that returns the last row of a worksheet:
Public Function funcLastRow(shtTarget As Worksheet, Optional iColLimit As Integer = -1) As Long
If iColLimit = -1 Then
iColLimit = 256
End If
Dim rowMaxIndex As Long
rowMaxIndex = 0
Dim ctrCols As Integer
For ctrCols = 1 To iColLimit
If shtTarget.Cells(1048576, ctrCols).End(xlUp).Row > rowMaxIndex Then
rowMaxIndex = shtTarget.Cells(1048576, ctrCols).End(xlUp).Row
End If
Next ctrCols
funcLastRow = rowMaxIndex
End Function
You could use it simply like so:
Dim lLastRow As Long
lLastRow = funcLastRow(Sheets(1))
Please let us know if that worked for you thanks
Here is an all formula solution (No Macro)
Data is in Sheet1 A to I and Sheet2 A to G
I am assuming you have only 6 departments. although if you have additional, the formulas need very little or may be no modification.
In Sheet 3
Get the userID repeated six times
A2 = INDEX(Sheet1!A:A,1+QUOTIENT(ROW()-ROW($A$2)+6,6))
Get Name, Gender & Country
B2 = VLOOKUP($A2,Sheet1!$A$2:$I$3000,COLUMNS($A$1:B$1),FALSE)
C2 = VLOOKUP($A2,Sheet1!$A$2:$I$3000,COLUMNS($A$1:C$1),FALSE)
D2 = VLOOKUP($A2,Sheet1!$A$2:$I$3000,COLUMNS($A$1:D$1),FALSE)
Get Access to department. The "" & ... is to avoid 0 in case the resulting cell was blank.
E2 = "" & IF(SUMPRODUCT(--(Sheet1!$A$1:$I$1=F2))>0,HLOOKUP(F2,Sheet1!$A$1:$I$3000,MATCH(A2,Sheet1!$A$1:$A$3000,0),FALSE),HLOOKUP(F2,Sheet2!$A$1:$G$3000,MATCH(A2,Sheet2!$A$1:$A$3000,0),FALSE))
F2:F7 the departments are Input manually (no formula). F8 is linked to F2 so that the depts repeat when dragged down
G2 = "" & IF(SUMPRODUCT(--(Sheet1!$A$1:$I$1=F2))>0,INDEX(Sheet1!$I$1:$I$3000,MATCH(A2,Sheet1!$A$1:$A$3000,0)),INDEX(Sheet2!$G$1:$G$3000,MATCH(A2,Sheet1!$A$1:$A$3000,0)))
If you need, I can prepare a google sheet to demo. Cheers.
This code works very well for Transpose and concatenate of big data.
Sub ConcatData()
Dim X As Double
Dim DataArray(5000, 2) As Variant
Dim NbrFound As Double
Dim Y As Double
Dim Found As Integer
Dim NewWks As Worksheet
Cells(1, 1).Select
Let X = ActiveCell.Row
Do While True
If Len(Cells(X, 1).Value) = Empty Then
Exit Do
End If
If NbrFound = 0 Then
NbrFound = 1
DataArray(1, 1) = Cells(X, 1)
DataArray(1, 2) = Cells(X, 2)
Else
For Y = 1 To NbrFound
Found = 0
If DataArray(Y, 1) = Cells(X, 1).Value Then
DataArray(Y, 2) = DataArray(Y, 2) & ", " & Cells(X, 2)
Found = 1
Exit For
End If
Next
If Found = 0 Then
NbrFound = NbrFound + 1
DataArray(NbrFound, 1) = Cells(X, 1).Value
DataArray(NbrFound, 2) = Cells(X, 2).Value
End If
End If
X = X + 1
Loop
Set NewWks = Worksheets.Add
NewWks.Name = "SummarizedData"
Cells(1, 1).Value = "Names"
Cells(1, 2).Value = "Results"
X = 2
For Y = 1 To NbrFound
Cells(X, 1).Value = DataArray(Y, 1)
Cells(X, 2).Value = DataArray(Y, 2)
X = X + 1
Next
Beep
MsgBox ("Summary is done!")
End Sub

'If ... Then' statement with loop

I've what seems like a pretty simple application with looping and 'If..Then' statements but need some help on structuring it.
In very a basic example, I have a list numbers in column A and the values PM or AM listed in column B. I want to write a loop that will search every value in column B until the end of the data set, and add 12 to each value in column A each time column B has a value of PM. In a nutshell, it would look like this:
If column B = PM
then add 12 to its corresponding cell in column A
else move down to the next row and do the same thing until you reach an empty cell
There are many ways, here is a typical one:
Sub dural()
Dim i As Long
i = 1
Do While Cells(i, "B").Value <> ""
If Cells(i, "B").Value = "PM" Then
Cells(i, "A").Value = Cells(i, "A").Value + 12
End If
i = i + 1
Loop
End Sub
you can set it with For next loop and 2 variables. one for last row and the 2nd for the row count:
Sub Macro1()
Dim LastRow As String
Dim i As Integer
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
For i = 1 To LastRow
If Cells(i, 2).Value = "PM" Then Cells(i, 1).vlaue = Cells(i, 1).vlaue + 10
Next i
End
'
End Sub
This is another way to do this.
Option Explicit
Sub Add()
Dim rData As Range
Dim r As Range
Set rData = Cells(1, 1).CurrentRegion.Columns("B").Cells
For Each r In rData
If UCase$(r.Value) = "PM" Then
r.Offset(, -1).Value = r.Offset(, -1).Value + 12
End If
Next r
End Sub

Excel VBA: Insert new row in multiple sheets

I have a userform where the user inputs data and then clicks the button Add.
The VBA then creates a new row and inputs the data from the user into that row.
This works fine, however I want to also add a new row in a different sheet as well and this is where I am stuck.
This is my code:
Dim i As String
Dim j As String
Dim k As String
Dim m As String
Dim n As String
j = XIDBox.Value
i = OrgNameBox.Value
k = ContactNameBox.Value
m = PhoneBox.Value
n = EmailBox.Value
dstRw = Sheets("Input Data").Range("A" & Rows.Count).End(xlUp).Row + 1
Sheets("Input Data").Cells(dstRw, 1).Value = i
Sheets("Input Data").Cells(dstRw, 2).Value = j
Sheets("Input Data").Cells(dstRw, 4).Value = k
Sheets("Input Data").Cells(dstRw, 6).Value = m
Sheets("Input Data").Cells(dstRw, 5).Value = n
'Here I want a code that inserts a blank row just as dstRw does above but in a different sheet.
The process is very similar to what you have in place.
'Here I want a code that inserts a blank row just as dstRw does above but in a different sheet.
Dim otherSheet As Worksheet
Set otherSheet = Sheets("Other Sheet Name")
' Insert as the last row.
Dim otherRow As Long
otherRow = otherSheet.Range("A" & Rows.Count).End(xlUp).Row + 1
' Now write the values.
otherSheet.Cells(otherRow, 1).Value = i
otherSheet.Cells(otherRow, 2).Value = j
otherSheet.Cells(otherRow, 4).Value = k
otherSheet.Cells(otherRow, 6).Value = m
otherSheet.Cells(otherRow, 5).Value = n
This works for both sheets using an array for your sheets. You can expand it by adding items to the array in the same manner. You also don't need to store the values as variables, since the name of the object is small, you can just set the cell's values directly from the source.
This finds the last row for each sheet, adds 1 and then sets the values of the cells from your source objects. Then loops the process for the next sheet in the array.
TESTED:
Sub ValueMove()
Dim dstRw As Long
Dim sheet(1) As String
sheet(0) = "Input Data"
sheet(1) = "Different Sheet"
For s = 0 To 1
dstRw = Sheets(sheet(s)).Range("A" & Rows.count).End(xlUp).row + 1
Sheets(sheet(s)).Cells(dstRw, 1).Value = OrgNameBox.Value
Sheets(sheet(s)).Cells(dstRw, 2).Value = XIDBox.Value
Sheets(sheet(s)).Cells(dstRw, 4).Value = ContactNameBox.Value
Sheets(sheet(s)).Cells(dstRw, 6).Value = PhoneBox.Value
Sheets(sheet(s)).Cells(dstRw, 5).Value = EmailBox.Value
Next s
End Sub