How to copy-paste in macro excel (VBA) - vba

I need to copy a lot of rows. I tried to do something.copy something else.paste but it's extremely slow
I tried to do
Range(..).value(formula) = Range(..).value(formula) but its not so good because i have a date there that turn to ######
I need a faster way to do this copy/paste
This is my code:
Function Last_Col(k As Long) As Long
Last_Col = Cells(k, Columns.Count).End(xlToLeft).Column
End Function
Function Last_Col_Doc() As Long
Last_Col_Doc = Cells.SpecialCells(xlCellTypeLastCell).Offset(1, 0).Column
End Function
Function Is_Grouped(i As Long) As Boolean
Is_Grouped = (Cells(i, 2).Rows.OutlineLevel > 1)
End Function
Function Is_Bold(i As Long) As Boolean
Is_Bold = Cells(i, 2).Font.Bold
End Function
Function Print_NA(i As Long, k As Long) As Boolean
Range(Cells(i, 21), Cells(i, 21 + k - 2)).Value = "NA"
End Function
Function Last_Row() As Long
Last_Row = Cells(Rows.Count, "B").End(xlUp).Row
End Function
Sub EditParanoia()
Dim FrstBlkRow As Long
Dim flag As Boolean
Dim i As Long
Dim HeadLen As Long
FrstBlkRow = Last_Col(1) + 1
If FrstBlkRow < 25 Then 'first edit
flag = True
i = 2
Do While flag
If Is_Bold(i) Then
flag = False
Else
i = i + 1
End If
Loop
HeadLen = Last_Col(i)
Range(Cells(i, 2), Cells(i, HeadLen)).Copy
Range(Cells(1, FrstBlkRow), Cells(1, FrstBlkRow + HeadLen - 2)).PasteSpecial
Else
FrstBlkRow = 21
HeadLen = 10
End If
Dim j As Long
For i = 2 To Last_Row Step 1
If Not Is_Grouped(i) And Not Is_Grouped(i + 1) And Cells(i, FrstBlkRow + 1).Value = vbNullString Then
'if not part of group
Range(Cells(i, FrstBlkRow), Cells(i, FrstBlkRow + HeadLen - 2)).Value = "NA"
ElseIf Not Is_Grouped(i) And Is_Grouped(i + 1) And Is_Grouped(i + 2) And Not Is_Grouped(i + 3) Then
'if Part of group of 1 val
Range(Cells(i + 2, 2), Cells(i + 2, 2 + HeadLen - 2)).Copy
Range(Cells(i, FrstBlkRow), Cells(i, FrstBlkRow + HeadLen - 3)).PasteSpecial
ElseIf Not Is_Grouped(i) And Is_Grouped(i + 1) Then
'if part of group of more then one val
j = 1
Do Until Is_Grouped(i + j) And Not Is_Grouped(i + j + 1)
'j will get the langth of any group
j = j + 1
Loop
'past the relevant cell in the right place
Range(Cells(i + 2, 2), Cells(i + 2 + j - 1 - 1, 2 + HeadLen - 2)).Copy
Range(Cells(i, FrstBlkRow), Cells(i + j - 1 - 1, FrstBlkRow + HeadLen - 3)).PasteSpecial
'past the head respectively
Range(Cells(i, 1), Cells(i, 20)).Copy
Range(Cells(i + 1, 1), Cells(i + j - 2, FrstBlkRow - 1)).PasteSpecial
End If
Next
End Sub

When you say you've tried "Range(..).value(formula) = Range(..).value(formula)", what do you mean? You should be able to set two ranges equal to eachother:
Say A1:A10 has "Batman, 10-01-2015" and you want to copy that range to B1:B10, Range("B1:B10").Value = Range("A1:A10").Value. You can't do that? I tried it with dates, and it set the B range values to dates, no reformatting necessary.
I also notice in your code, you PasteSpecial, but don't specify what type of special paste. See the Microsoft (or this one) page for more info.

Related

Only transpose data to a new column if it is a new group of data / excel vba

I have a column of data in excel which could potentially have data over 2000 rows. In that data there is groups of data that I would like to send to the top of a new column every time a new group is found. I've looked at the special paste option for transpose along with using a delimiter but i can only move data one column over and not to the top. I'm looking for a solution which is fast due to the amount of data that would need to be split into new columns. I appreciate the help.
Below is a table of how the data looks.
Below is how I would like the data to look
Try this simple code,
Sub splitRange()
Dim i As Long, j As Long, k As Long
Cells(1, 6) = Cells(1, 1)
Cells(1, 7) = Cells(1, 2)
j = 1
k = 6
For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row
If Cells(i, 1) = Cells(i - 1, 1) Then
j = j + 1
Cells(j, k) = Cells(i, 1)
Cells(j, k + 1) = Cells(i, 2)
Else
k = k + 3
j = 1
Cells(j, k) = Cells(i, 1)
Cells(j, k + 1) = Cells(i, 2)
End If
Next i
End Sub
Modify the code if you want the output in a separate sheet. I would like you to google it to learn about it.
I had to do something similar. You can try also this code:
Sub Move_Data()
Application.ScreenUpdating = False
Dim r As Integer
Dim StartRow As Integer
Dim EndRow As Integer
Dim ColA As Integer
Dim vLastRow As Integer
Dim vEnd As Integer
r = 1
StartRow = 1
EndRow = 1
ColA = 4
vEnd = 1
vLastRow = Cells.Find("*", [A1], , , xlByRows, xlPrevious).Row
Do Until Cells(r, 1) <> Cells(StartRow, 1)
DoEvents
r = r + 1
Loop
vEnd = r
Do Until r > vLastRow
DoEvents
StartRow = r
Do Until Cells(r, 1) <> Cells(StartRow, 1)
DoEvents
r = r + 1
Loop
EndRow = r - 1
Range(Cells(StartRow, 1), Cells(EndRow, 2)).Select
Selection.Copy
Cells(1, ColA).Select
ActiveSheet.Paste
ColA = ColA + 3
Loop
r = vEnd + 1
Range(Cells(vEnd, 1), Cells(vLastRow, 2)).ClearContents
Cells(1, 1).Select
Application.ScreenUpdating = True
MsgBox "Done"
End Sub

Insert row where sequential value is missing, Excel VBA

I am using the following VBA code to insert a blank row where a sequential value is missing in excel.
Sub test()
Dim i As Long, x, r As Range
For i = Range("b" & Rows.Count).End(xlUp).Row To 2 Step -1
x = Mid$(Cells(i, "b"), 2) - Mid$(Cells(i - 1, "b"), 2)
If x > 1 Then
Rows(i).Resize(x - 1).Insert
Cells(i - 1, "b").AutoFill Cells(i - 1, "b").Resize(x), 2
End If
Next
This works fine unless the last value is missing.
For example I am filling in the blanks for groups of 5.
Where middle numbers are missing:
1
2
4
5
The code will insert a blank row for the missing value to become:
1
2
4
5
However if the last value, 5, was missing, a row will not be inserted.
So:
1
2
4
Becomes:
1
2
4
Is there a way to set a maximum to ensure the final value will be recognised as missing?
Try this...
Sub test()
Dim i As Long, x, r As Range, lMax As Long, lRw As Long
lRw = Range("b" & Rows.Count).End(xlUp).Row + 1
lMax = InputBox("Enter Maximum Value", "Maximum Input Req.", Application.Max(Range("B2:B" & lRw)))
For i = lRw To 2 Step -1
If i = lRw Then
x = lMax - Mid$(Cells(i - 1, "b"), 2)
If x > 1 Then
Cells(i - 1, "b").AutoFill Cells(i - 1, "b").Resize(x + 1), 2
End If
Else
x = Mid$(Cells(i, "b"), 2) - Mid$(Cells(i - 1, "b"), 2)
If x > 1 Then
Rows(i).Resize(x - 1).Insert
Cells(i - 1, "b").AutoFill Cells(i - 1, "b").Resize(x), 2
End If
End If
Next
End Sub
Revised Code
Sub test()
Dim i As Long, x, r As Range, lMax As Long, lRw As Long
lRw = Range("b" & Rows.Count).End(xlUp).Row + 1
lMax = InputBox("Enter Maximum Value", "Maximum Input Req.", Application.Max(Range("B2:B" & lRw)))
For i = lRw To 2 Step -1
If i = lRw Then
x = lMax - Cells(i - 1, "b").Value
If x > 1 Then
Cells(i - 1, "b").AutoFill Cells(i - 1, "b").Resize(x + 1), 2
End If
Else
x = Cells(i, "b").Value - Cells(i - 1, "b").Value
If x > 1 Then
Rows(i).Resize(x - 1).Insert
Cells(i - 1, "b").AutoFill Cells(i - 1, "b").Resize(x), 2
End If
End If
Next
End Sub
This answer was given to me on another forum:
http://www.ozgrid.com/forum/showthread.php?t=200184&goto=newpost**
Sub Reply()
i = 1
Do While Cells(i, 2) <> ""
j = Cells(i + 1, 2).Value - Cells(i, 2).Value - 1
If j < 0 Then j = 8 - Cells(i, 2).Value + Cells(i + 1, 2).Value
For k = 1 To j
Rows(i + k).EntireRow.Insert
Next k
i = i + k
Loop
End Sub

Add missing dates VBA

I have to insert missing dates to a row without deleting the duplicated dates (for a billing program). Example data:
DATE
01/02/2016
02/02/2016
03/02/2016
03/02/2016
03/02/2016
06/02/2016
07/02/2016
08/02/2016
My code is infinitely looping and deleting the duplicate dates. Why does this happen?
Sub InsertMissingDates()
Dim i As Long
Dim RowCount As Long
i = 4
Do
If Cells(i, 1) + 1 <> Cells(i + 1, 1) Then
Rows(i + 1).Insert
Cells(i + 1, 1) = Cells(i, 1) + 1
End If
i = i + 1
Loop Until Cells(i + 1, 1) = "31.10.2016"
End Sub
Here is the code modified with comments to address your issues
Sub InsertMissingDates()
Dim i As Long
Dim RowCount As Long
i = 4
Do
'Use less then instead of <> so it doesn't flag duplicate cells
If Cells(i, 1) + 1 < Cells(i + 1, 1) Then
Rows(i + 1).Insert
Cells(i + 1, 1) = Cells(i, 1) + 1
End If
'Second check to add value if the next row is blank
If (Cells(i + 1, 1) = "") Then
Cells(i + 1, 1) = Cells(i, 1) + 1
End If
i = i + 1
'Changed the loop function from cells(i+1,1) to cells(i,1) since you already
'incremented i
'Also made the date check slightly more robust with dateserial
Loop Until Cells(i, 1).Value >= DateSerial(2016, 1, 30)
End Sub

VBA code delete the row of noisy data

Sub project()
Dim a, deltat_value1, deltat_value2, deltat_value3 As Integer
a = 2
Do
deltat_value1 = Cells(a, 7).Value
deltat_value2 = Cells(a + 1, 7).Value
deltat_value3 = Cells(a + 2, 7).Value
If Abs(deltat_value1 - deltat_value2) > 5 And Abs(deltat_value2 - deltat_value3) > 5 Then
Rows(a + 1).EntireRow.Delete
End If
a = a + 1
Loop Until deltat_value1 = 14700
End Sub
I am trying to delete the noisy data, I set if a data point that it has a difference bigger than 5 from both the points above and below it, that is a noisy data and I set to delete the whole row of the noisy data.
However, I am having this problem for the line:
deltat_value3=Cells(a+2,7).Value
Runtime Error 1004 "Application-defined or Object-defined error"
And the running takes extremely longer time. I am a new user of VBA programming and I think my method may be inefficient, there may be other ways work much better, any advice?
How about:
Sub ytrewq()
Dim a As Long, deltat_value1 As Long, deltat_value2 As Long, deltat_value3 As Long
Dim rKill As Range
a = 2
Do
deltat_value1 = Cells(a, 7).Value
deltat_value2 = Cells(a + 1, 7).Value
deltat_value3 = Cells(a + 2, 7).Value
If Abs(deltat_value1 - deltat_value2) > 5 And Abs(deltat_value2 - deltat_value3) > 5 Then
If rKill Is Nothing Then
Set rKill = Cells(a + 1, 1)
Else
Set rKill = Union(rKill, Cells(a + 1, 1))
End If
End If
a = a + 1
Loop Until deltat_value1 = 14700
rKill.EntireRow.Delete
End Sub

VBA Return Carriage and Fill Code

I'm really new to vba and would appreciate any assistance in the following problem I'm having.
Problem description (in relation to diagram below):
1*) In c, I have managed to separate the return carriages, which leads to 2*) now that each return carriage has it's own row, I need column b and c on either side to be filled down as shown in result 3*)
1*) b c e
y 1,2,3,4 y
z 5,6,7,8 z
2*) b c e
y 1 y
2
3
4
z 5 z
6
7
8
3*) b c e
y 1 y
y 2 y
y 3 y
y 4 y
z 5 z
z 6 z
z 7 z
z 8 z
I have included my original code for everyone to inspect, I am currently stuck as to how I would get to step 3.
Sub InString()
Dim rColumn As Range 'Set this to the column which needs to be worked through
Dim lFirstRow As Long
Dim lLastRow As Long
Dim lRow As Long 'Difference between first and last row
Dim lLFs As Long
Dim rRow As Range 'This will be used to drag the fill down between rows
Set rColumn = Columns("N")
lFirstRow = 2 'Starting may need to be adjusted, if additional columns are added
lLastRow = rColumn.Cells(Rows.Count).End(xlUp).Row
For lRow = lLastRow To lFirstRow Step -1
lLFs = Len(rColumn.Cells(lRow)) - Len(Replace(rColumn.Cells(lRow), vbLf, ""))
If lLFs > 0 Then
rColumn.Cells(lRow + 1).Resize(lLFs).EntireRow.Insert shift:=xlShiftDown 'added EntireRow to before insert, to bring whole row down, instead of previous issue where only rColumn was shifted down.
rColumn.Cells(lRow).Resize(lLFs + 1).Value = Application.Transpose(Split(rColumn.Cells(lRow), vbLf))
End If
Next lRow
End Sub
Thanks,
I just added a loop at the end looking for blanks -
Sub InString()
Dim rColumn As Range 'Set this to the column which needs to be worked through
Dim lFirstRow As Long
Dim lLastRow As Long
Dim lRow As Long 'Difference between first and last row
Dim lLFs As Long
Dim rRow As Range 'This will be used to drag the fill down between rows
Dim strVal As String
Set rColumn = Columns("N")
lFirstRow = 2 'Starting may need to be adjusted, if additional columns are added
lLastRow = rColumn.Cells(Rows.Count).End(xlUp).row
For lRow = lLastRow To lFirstRow Step -1
lLFs = Len(rColumn.Cells(lRow)) - Len(Replace(rColumn.Cells(lRow), vbLf, ""))
If lLFs > 0 Then
rColumn.Cells(lRow + 1).Resize(lLFs).EntireRow.Insert shift:=xlShiftDown 'added EntireRow to before insert, to bring whole row down, instead of previous issue where only rColumn was shifted down.
rColumn.Cells(lRow).Resize(lLFs + 1).Value = Application.Transpose(Split(rColumn.Cells(lRow), vbLf))
End If
Next lRow
lLastRow = rColumn.Cells(Rows.Count).End(xlUp).row
Dim rColNum As Integer
rColNum = rColumn.Column
For i = 2 To lLastRow
If Cells(i, rColNum - 1) = "" Then
Cells(i, rColNum - 1) = Cells(i - 1, rColNum - 1)
Cells(i, rColNum + 1) = Cells(i - 1, rColNum + 1)
End If
Next
End Sub
Basically this part -
For i = 2 To lLastRow
If Cells(i, rColNum - 1) = "" Then
Cells(i, rColNum - 1) = Cells(i - 1, rColNum - 1)
Cells(i, rColNum + 1) = Cells(i - 1, rColNum + 1)
End If
Next
Says, look at each row in the column we just split and see if the cell to the left is blank. If it is, make it the same as the one above it AND make the cell to the right the same as the one above it.
To expand, you might then say
if Cells(i, rColNum - 1) = "" Then
Cells(i, rColNum - 1) = Cells(i - 1, rColNum - 1)
Cells(i, rColNum + 1) = Cells(i - 1, rColNum + 1)
Cells(i, rColNum - 2) = Cells(i - 1, rColNum - 2)
Cells(i, rColNum + 2) = Cells(i - 1, rColNum + 2)
End If
If you wanted to cover the adjacent two columns on either side of rcolumn.
Assuming your input data is in columns B, D and E (as your diagram suggests) then this does the job I think:
Sub OrderData()
Dim inputData As Range, temp() As Variant, splitData As Variant, i As Integer, j As Integer, rw As Long
Set inputData = Range("B1:E2") //Update to reflect your data
temp = inputData.Value
inputData.ClearContents
rw = 1
For i = 1 To UBound(temp)
splitData = Split(temp(i, 2), ",")
For j = 0 To UBound(splitData)
Cells(rw, 2) = temp(i, 1)
Cells(rw, 3) = splitData(j)
Cells(rw, 5) = temp(i, 4)
rw = rw + 1
Next j
Next i
End Sub