Copy data with in sheets - excel

enter image description hereThere are 2 sheets, Sheet1 and Sheet2.
Sheet1 contain 10 columns and 5 rows with data including blank.
The requirement is to copy the data from Sheet 1 and to put in another sheet Sheet 2, wherein only populate the cell which is not blank.
I get the run time error 1004 - Application or object defined error.
The code snippet is:-
Set wsht1 = ThisWorkbook.Worksheets("Sheet1")
Set wsht2 = Sheets("Sheet2")
finalrow = wsht1.Cells(wsht1.Rows.Count, 1).End(xlUp).Row
For i = 1 To finalrow
If wsht1.Cells(i, 1).Value <> " " Then
Range(Cells(i, 2), Cells(i, 2)).Copy
Worksheets("Sheet2").Select
wsht2.Range(Cells(1, i)).PasteSpecial Paste:=xlPasteFormats
End If
Next i
Can u help me in sorting this out?

You cannot define a range like that:
wsht2.Range(Cells(1, i))
you might use:
wsht2.Cells(1, i).PasteSpecial Paste:=xlPasteFormats
BTW: with this code you won't find empty cells:
If wsht1.Cells(i, 1).Value <> " " Then
you should use:
If wsht1.Cells(i, 1).Value <> "" Then
(the difference is a missing space between the quotes)
if you want to copy the values only and to make it with a loop I'd do the following:
Sub copying()
Set wsht1 = ThisWorkbook.Worksheets("Sheet1")
Set wsht2 = Sheets("Sheet2")
finalrow = wsht1.Cells(wsht1.Rows.Count, 1).End(xlUp).Row
For i = 1 To finalrow
If wsht1.Cells(i, 1).Value <> "" Then
For j = 1 To 5
wsht2.Cells(i, j).Value = wsht1.Cells(i, j).Value
Next j
End If
Next i
End Sub

If you only have 5 cells with data in Sheet 1 and only want those 5 rows copying to Sheet 2 use the following, similar to Shai's answer above with an extra counter for the rows in Sheet 2.
Sub copying()
Set wsht1 = ThisWorkbook.Worksheets("Sheet1")
Set wsht2 = Sheets("Sheet2")
finalrow = wsht1.Cells(wsht1.Rows.Count, 1).End(xlUp).Row
k = 1
For i = 1 To finalrow
If wsht1.Cells(i, 1).Value <> "" Then
For j = 1 To 5
wsht2.Cells(k, j).Value = wsht1.Cells(i, j).Value
Next j
k = k + 1
End If
Next i
End Sub
EDIT
As per your comment if you want to dynamically change j replace For j = 1 To 5 with
For j = 1 To wsht1.Cells(i, Columns.Count).End(xlToLeft).Column

The code below will copy only values in Column A (non-empty cells) from Sheet 1 to Sheet2:
Dim j As Long
Set wsht1 = ThisWorkbook.Worksheets("Sheet1")
Set wsht2 = Sheets("Sheet2")
finalrow = wsht1.Cells(wsht1.Rows.Count, 1).End(xlUp).Row
j = 1
For i = 1 To finalrow
With wsht1
' if you compare to empty string, you need to remove the space inside the quotes
If .Cells(i, 1).Value <> "" And .Cells(i, 1).Value <> " " Then
.Cells(i, 1).Copy ' since you are copying a single cell, there's no need to use a Range
wsht2.Range("A" & j).PasteSpecial Paste:=xlPasteValues, Paste:=xlPasteFormats
j = j + 1
End If
End With
Next i

Related

vba for loop for 4 different column

Dim I As Long
For I = 2 To lastrow
If Not IsEmpty(Cells(I, "f")) And IsEmpty(Cells(I, "j")) Then
Cells(I, "j").Value = "unregister"
End If
Next I
Dim I2 As Long
For I2 = 2 To lastrow
If IsEmpty(Cells(I2, "f")) Then
Cells(I2, "i").Value = Cells(I2 - 1, "i").Value
End If
Next I2
can you make this code more simple i want to copy above row for 3 different column if column f is empty
You can do something like this, using a single loop and Offset(-1, 0) to get the cell above:
Dim i As Long, ws As Worksheet
Set ws = ActiveSheet
For i = 2 To ws.Cells(ws.Rows.Count, "F").End(xlUp).Row
With ws.Rows(i)
If Not IsEmpty(.Columns("F")) Then
If IsEmpty(.Columns("J")) Then .Columns("J").Value = "unregister"
Else
.Columns("I").Value = .Columns("I").Offset(-1, 0).Value
.Columns("L").Value = .Columns("L").Offset(-1, 0).Value
'etc
End If
End With
Next I2

Avoid copying buttons in range

i have a macro where i copy paste a range, which also has buttons in there.
Now i dont want the buttons to get copied. How can i do that?
I copy the whole table and insert it again at A32.
lrow = .Cells(Rows.Count, 1).End(xlUp).row
Do While counter = 0
For i = 32 To lrow
If .Cells(i, 1).Value = "Review Participants" And counter = 1 Then
lastrev = lrowrev
lrowrev = i - 1 'row where the second last review starts
aboveR = lrowrev - lastrev
Exit For
ElseIf .Cells(i, 1).Value = "Review Participants" And counter <> 1 Then
counter = counter + 1
lrowrev = i
lcol = 11 'hardcode last col ~~ Alt: 'lcol = .Cells(i + 1, .Columns.Count).End(xlToLeft).Column 'last meeting of the review is our reference for lastcol
ElseIf counter = 1 And i = lrow Then
lrowrev = i + 2
aboveR = (i + 2) - 32
Exit For
End If
Next
Loop
lastcolumn = Split(Cells(, lcol).Address, "$")(1)
Set rngtocopy = .Range("A" & 32 & ":" & lastcolumn & lrowrev)
Debug.Print rngtocopy.Address
'aboveR = .Range("A" & 32 & ":" & lastcolumn & lrowrev - 1).Rows.Count ' amount of rows copied
Set rngins = .Range("A32").EntireRow
Debug.Print rngins.EntireRow.Resize(aboveR + 2).Address
rngins.EntireRow.Resize(aboveR + 2).Insert xlShiftDown 'insert the amount of rows, we copied
'Range("A" & lrow).Offset(5).EntireRow.Hidden = False
Set rngins = .Range("A32")
Debug.Print rngins.Address
rngtocopy.Copy
rngins.PasteSpecial Paste:=xlPasteAll
Try this code, please:
Sub copyRangeNoButt()
Dim sh As Worksheet, rng As Range, arrRng As Variant
Set sh = ActiveSheet
Set rng = sh.Range("D2:E10"): rng.Copy
arrRng = rng.value
With sh.Range("H2").Resize(UBound(arrRng, 1), UBound(arrRng, 2))
.value = arrRng
.PasteSpecial xlPasteFormats'comment this line if format is not needed. It takes much more time than all the rest of the code, in case of a big range...
End With
End Sub
Of course, you must adapt the code to use your range to be copied definition and the cell where to be pasted (even if in another worksheet).
Now i dont want the buttons to get copied. How can i do that?
You can also use PasteSpecial. You can take advantage of XlPasteType enumeration to copy and paste only relevant part. For example, here is a one liner in case you want to paste
A. Everything except the image
rng.PasteSpecial Paste:=xlPasteAllUsingSourceTheme
B. Only Values
rng.PasteSpecial Paste:=xlPasteValues
In action

Copy and pasting all values from one sheet to another

I have a macro that creates a sheet full of data. I recently added new sheets so that unique values can go into each one. For example if a row contains "Pole Change Out" then that entire row is copy and pasted into the "Pole Change Out" sheet. there are 4 different sheets. My problem is, since some values are determined by a formula in vba, some values are not moving into the new sheet.
Sub copy_paste_based_on_cell_interior_rgb()
Dim LastRow As Long
Dim i As Long, j As Long
'Find the last used row in a Column: column A in this example
With Worksheets("Make-Ready")
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
'first row number where you need to paste values in Sheet1'
With Worksheets("Pole Change Out")
j = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
End With
For i = 1 To LastRow
With Worksheets("Make-Ready")
If .Cells(i, 27).Value = "Pole Change-Out" Then
.Rows(i).Copy Destination:=Worksheets("Pole Change Out").Range("A" & j)
j = j + 1
ElseIf .Cells(i, 27).Value = "New Midspan Pole" Then
.Rows(i).Copy Destination:=Worksheets("Midspan Poles").Range("A" & j)
j = j + 1
ElseIf .Cells(i, 104).Value = "Yes" Then
.Rows(i).Copy Destination:=Worksheets("Anchor Replacement").Range("A" & j)
j = j + 1
End If
End With
Next i
End Sub
As #scottCraner and the others pointed out. You are trying to use the first empty cell variable from one sheet on the other two sheets. The update to your code will automatically update the first blank cell for each sheet.
Sub copy_paste_based_on_cell_interior_rgb()
Dim LastRow As Long
Dim i As Long ', j As Long
'Find the last used row in a Column: column A in this example
With Worksheets("Make-Ready")
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
'first row number where you need to paste values in Sheet1'
'With Worksheets("Pole Change Out")
' j = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
'End With
For i = 1 To LastRow
With Worksheets("Make-Ready")
If .Cells(i, 27).Value = "Pole Change-Out" Then
.Rows(i).Copy Destination:=Worksheets("Pole Change Out").Cells(Rows.Count, 1).End(xlUp).Offset(1)
'j = j + 1
ElseIf .Cells(i, 27).Value = "New Midspan Pole" Then
.Rows(i).Copy Destination:=Worksheets("Midspan Poles").Cells(Rows.Count, 1).End(xlUp).Offset(1)
'j = j + 1
ElseIf .Cells(i, 104).Value = "Yes" Then
.Rows(i).Copy Destination:=Worksheets("Anchor Replacement").Cells(Rows.Count, 1).End(xlUp).Offset(1)
'j = j + 1
End If
End With
Next i
End Sub

Row to Column in Excel

I have a set of data in this format:-
Note: It starts from Jan-17 to Dec-17. However, for this exercise I limit it to 3 months (Jan to Mar).
I wish to convert the data into this format:-
How can i achieve it using Excel?
Thanks in advance.
How about something like below, using a double For Loop to loop through rows and then columns and transfer data to Sheet2 in the desired format (this won't add the headers to Sheet2, but it will give you a some guidance as to how to go about it):
Sub Summarize()
Dim ws As Worksheet: Set ws = Sheets("Sheet1") 'Sheet with data
Dim ws2 As Worksheet: Set ws2 = Sheets("Sheet2") 'Summarised Sheet
'declare and set your worksheet, amend as required
LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
'get the last row with data on Column A
LastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
For i = 2 To LastRow 'loop through rows
For col = 6 To 14 Step 4 'loop through columns
'replace 14 with (LastCol - 4) if you wish to do all the months instead of just the first 3
FreeRow = ws2.Cells(ws2.Rows.Count, "A").End(xlUp).Row + 1 'get the next free row to transfer data to
ws.Range("A" & i & ":D" & i).Copy ws2.Range("A" & FreeRow) 'copy the first 4 columns into the free row
ws2.Cells(FreeRow, 5).Value = "20" & Mid(ws.Cells(1, col).Value, 5, 2) 'get the year from the header
ws2.Cells(FreeRow, 6).Value = Left(ws.Cells(1, col).Value, 3) ' get the month name from header
ws2.Cells(FreeRow, 7).Value = ws.Cells(i, col).Value 'transfer values
ws2.Cells(FreeRow, 8).Value = ws.Cells(i, col + 1).Value
ws2.Cells(FreeRow, 9).Value = ws.Cells(i, col + 2).Value
ws2.Cells(FreeRow, 10).Value = ws.Cells(i, col + 3).Value
Next col
Next i
End Sub
UPDATE:
I've added a couple of lines to the code to attempt to optimize the speed of it, also removed the Copy & Paste and altered it to pass the values without copying anything, please have a look below:
Sub Summarize()
Dim ws As Worksheet: Set ws = Sheets("Sheet1") 'Sheet with data
Dim ws2 As Worksheet: Set ws2 = Sheets("Sheet2") 'Summarised Sheet
'declare and set your worksheet, amend as required
LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
'get the last row with data on Column A
LastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
'optimize code:
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.EnableEvents = False
For i = 2 To LastRow 'loop through rows
For col = 6 To 14 Step 4 'loop through columns
'replace 14 with (LastCol - 4) if you wish to do all the months instead of just the first 3
FreeRow = ws2.Cells(ws2.Rows.Count, "A").End(xlUp).Row + 1 'get the next free row to transfer data to
ws2.Cells(FreeRow, 1).Value = ws.Cells(i, 1).Value
ws2.Cells(FreeRow, 2).Value = ws.Cells(i, 2).Value
ws2.Cells(FreeRow, 3).Value = ws.Cells(i, 3).Value
ws2.Cells(FreeRow, 4).Value = ws.Cells(i, 4).Value
ws2.Cells(FreeRow, 5).Value = "20" & Mid(ws.Cells(1, col).Value, 5, 2) 'get the year from the header
ws2.Cells(FreeRow, 6).Value = Left(ws.Cells(1, col).Value, 3) ' get the month name from header
ws2.Cells(FreeRow, 7).Value = ws.Cells(i, col).Value 'transfer values
ws2.Cells(FreeRow, 8).Value = ws.Cells(i, col + 1).Value
ws2.Cells(FreeRow, 9).Value = ws.Cells(i, col + 2).Value
ws2.Cells(FreeRow, 10).Value = ws.Cells(i, col + 3).Value
Next col
Next i
'return to normal Excel status after macro has finished
Application.EnableEvents = True
Application.DisplayStatusBar = True
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub

Copy cell and adjacent cell and insert as new row: Excel VBA

I'm trying to copy a cell and the adjacent cell in a row and insert it as a new row with all the data to the right of this cell also copied over. My data looks like this after mining.
and im trying to get my data to look like this:
the image above is just one record but essentially its moving all the people and their corresponding position in the original row to a new row. In each row there are about 5 employees and their positions.
thanks
EDIT Attempted code for just 2 cols. 1 position. the idea was to create the empty rows and just copy the rest of the data with auto fill, then work from there
Sub TransposeInsertRows()
Dim rng As Range
Dim i As Long, j As Long, k As Long
Dim x As Long, y As Long
Set rng = Application.InputBox _
(Prompt:="Range Selection...", _
Title:="Enter the name col and pos col", Type:=8)
Application.ScreenUpdating = False
x = rng(1, 1).Column + 2
y = rng(1, rng.Columns.Count).Column
For i = rng(rng.Rows.Count, 1).Row To rng(1, 1).Row Step -1
If Cells(i, x) <> "" And Cells(i, x + 1) <> "" Then
k = Cells(i, x - 2).End(xlToRight).Column
If k > y Then k = y
For j = k To x + 1 Step -1
Cells(i + 1, 1).EntireRow.Insert
With Cells(i + 1, x - 2)
.Value = .Offset(-1, 0)
.Offset(0, 1) = .Offset(-1, 1)
.Offset(0, 2) = Cells(i, j)
End With
Cells(i, j).ClearContents
Next j
End If
Next i
Application.ScreenUpdating = True
End Sub
If there are always 5 people in each row then this should do it:
Sub foo()
LastRow = Sheet1.Cells(Sheet1.Rows.Count, "A").End(xlUp).Row
For i = 1 To LastRow 'loop through rows
For x = 1 To 10 Step 2 'loop through columns
LastRow2 = Sheet2.Cells(Sheet2.Rows.Count, "A").End(xlUp).Row + 1 'find the next free row on Sheet2
Sheet2.Cells(LastRow2, 1).Value = Sheet1.Cells(i, x).Value 'add Person Name to Sheet2
Sheet2.Cells(LastRow2, 2).Value = Sheet1.Cells(i, x + 1).Value 'add position to Sheet2
Sheet1.Range("K" & i & ":U" & i).Copy Destination:=Sheet2.Cells(LastRow2, 3) 'copy range from K to U to Sheet2
Next x
Next i
End Sub

Resources