I have up to 6 cells with potential data coming from 6 different places. I am trying to get only the first three cells with data transferred to another sheet WITH THE ORIGINAL FORMAT Sub Transfer_Data()
Sub Transfer_Data()
Dim i As Long, j As Long
j = 1
For i = 1 To 6
If Sheets("Sheet1").Cells(i, 1).Value <> "" Then
Sheets("Sheet2").Cells(j, 1).Value = Sheets("Sheet1").Cells(i, 1).Value
j = j + 1
End If
If j > 3 Then Exit For
Next i
End Sub
what happens is it displays the sheet2 format and color when im trying to keep sheet1
Try it like this...
Sub Transfer_Data()
Dim i As Long, j As Long
j = 1
For i = 1 To 6
If Sheets("Sheet1").Cells(i, 1).Value <> "" Then
Sheets("Sheet1").Cells(i, 1).Copy
Sheets("Sheet2").Cells(j, 1).PasteSpecial xlPasteFormats
Sheets("Sheet2").Cells(j, 1).PasteSpecial xlPasteValues
j = j + 1
End If
If j > 3 Then Exit For
Next i
Application.CutCopyMode = False
End Sub
Edited code as per the new requirement:
Sub Transfer_Data()
Dim i As Long, j As Long
j = 1
For i = 1 To 6
If Sheets("Sheet1").Cells(i, 1).Value <> "" Then
Sheets("Sheet2").Cells(j, 1).Value = Sheets("Sheet1").Cells(i, 1).Value
Sheets("Sheet2").Cells(j, 1).Interior.Color = Sheets("Sheet1").Cells(i, 1).Interior.Color
j = j + 1
End If
If j > 3 Then Exit For
Next i
End Sub
Related
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
Can someone help me if this is possible to do?
Logic is: If ColA = 1 and ColC >=1 then it should copy the entire row and insert new row below the last blank cell before meeting the next cell that contains then 1 will become 0.
Raw:
Final output should be:
I tried to put it as text but it doesn't seem right. the code i have for now is only this, its my first project tho. my code is still incomplete as i don't know what to do next. i tried a lot of codes but not working. here's the code:
Dim asd As Integer
Dim LastRow As Long
LastRow = Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
For zxc = 2 To C
If Cells(zxc, "A").Value = 1 And Cells(zxc, "C").Value >= 1 Then
asd = asd + 1
End If
Next zxc
Dim AddCountRow As Long
AddCountRow = LastRow + asd
For i = 2 To AddCountRow
Dim A As Long
A = Worksheets("Sheet1").Cells(i, "A").Value
Dim B As Long
B = Worksheets("Sheet1"). Cells(i + 1, "D"). Value
If A >= 1 And B >= 1 Then
Cells(i + 1, "A").EntireRow.Insert
i = i + 1
End If
Next i
End Sub
Thank you so much guys!
This is a different approach. Considering maybe you have data below and
lastrow could not be reliable.
Look for the <<< Customize this >>> where I set the first cell where you have the header.
This code covers the data in the sample image:
Sub CopyInsertRows()
Dim colAValue As String
Dim colBValue As String
Dim colCValue As String
Dim colDValue As String
Dim initialCell As String
Dim rowCounter As Long
' <<< Customize this >>>
initialCell = "A4"
' Loop through all cells
For rowCounter = 2 To Rows.Count
If Range(initialCell).Cells(rowCounter, 1).Value <> vbNullString Then
colAValue = Range(initialCell).Cells(rowCounter, 1).Value
colBValue = Range(initialCell).Cells(rowCounter, 2).Value
colCValue = Range(initialCell).Cells(rowCounter, 3).Value
colDValue = Range(initialCell).Cells(rowCounter, 4).Value
ElseIf Range(initialCell).Cells(rowCounter, 1).Value = vbNullString And Range(initialCell).Cells(rowCounter + 1, 1).Value <> vbNullString Then
Range(initialCell).Cells(rowCounter + 1).EntireRow.Insert
Range(initialCell).Cells(rowCounter + 1, 1).Value = "0"
Range(initialCell).Cells(rowCounter + 1, 2).Value = colBValue
Range(initialCell).Cells(rowCounter + 1, 3).Value = colCValue
Range(initialCell).Cells(rowCounter + 1, 4).Value = colDValue
rowCounter = rowCounter + 1
End If
If Range(initialCell).Cells(rowCounter, 4).Value = vbNullString Then
Range(initialCell).Cells(rowCounter, 1).Value = "0"
Range(initialCell).Cells(rowCounter, 2).Value = colBValue
Range(initialCell).Cells(rowCounter, 3).Value = colCValue
Range(initialCell).Cells(rowCounter, 4).Value = colDValue
Exit For
End If
Next rowCounter
End Sub
This code covers the data in the sample linked file:
Sub CopyInsertRows()
Dim sourceRow As Range
Dim initialCell As String
Dim dateColumnLetter As String
Dim dateColumnNumber As Integer
Dim rowCounter As Long
' <<< Customize this >>>
initialCell = "A1" ' First cell of header row
dateColumnLetter = "AA" ' Where
' Get column number
dateColumnNumber = Range(dateColumnLetter & 1).Column
' Loop through all cells
For rowCounter = 2 To Rows.Count
If Range(initialCell).Cells(rowCounter, 1).Value <> vbNullString Then
' Store row values
Set sourceRow = Range(initialCell).Range("A" & rowCounter & ":" & dateColumnLetter & rowCounter)
ElseIf Range(initialCell).Cells(rowCounter, 1).Value = vbNullString And Range(initialCell).Cells(rowCounter + 1, 1).Value <> vbNullString Then
' Insert new row
Range(initialCell).Cells(rowCounter + 1).EntireRow.Insert
' Duplicate source row
Range(initialCell).Range("A" & rowCounter + 1 & ":" & dateColumnLetter & rowCounter + 1).Value = sourceRow.Value
' Replace first cell
Range(initialCell).Range("A" & rowCounter + 1).Value = "0"
rowCounter = rowCounter + 1
End If
If Range(initialCell).Cells(rowCounter, dateColumnNumber).Value = vbNullString Then
' Duplicate source row
Range(initialCell).Range("A" & rowCounter & ":Y" & rowCounter).Value = sourceRow.Value
' Replace first cell
Range(initialCell).Range("A" & rowCounter + 1).Value = "0"
Exit For
End If
Next rowCounter
End Sub
You will be inserting rows so work from the bottom up.
Sub addLines()
Dim i As Long, lr As Long, n As Long
With Worksheets("sheet5")
'collect last data row
lr = .Cells(.Rows.Count, "D").End(xlUp).Row + 1
'loop through the rows backwards, inserting rows and transferring values
For i = lr To 3 Step -1
If i = lr Or .Cells(i, "A") <> vbNullString Then
n = Application.Match(1E+99, .Range("A:A").Resize(i - 1, 1))
.Cells(i, "A").Resize(1, 4).Insert Shift:=xlDown
.Cells(i, "A").Resize(1, 4) = .Cells(n, "A").Resize(1, 4).Value
.Cells(i, "A") = 0
End If
Next i
End With
End Sub
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
i have to sort data from sheet1 to sheet2 with reference to non-empty cell in column A. and
i have written code for it as below:
Sub polo()
Dim lastrow As Long
lastrow = Sheets("Sheet1").Range("B" & Rows.Count).End(xlUp).Row
j = 2
For i = 1 To lastrow
If Sheets("Sheet1").Cells(i, 1).Value = "" Then
Sheets("Sheet2").Cells(j, 2).Value = Sheets("Sheet1").Cells(i, 1).Offset(, 1).Value
Sheets("Sheet2").Cells(j, 4).Value = Sheets("Sheet1").Cells(i - 1, 2).Value
j = j + 1
End If
Next i
End Sub
But the problem is, i am getting result as in column D of sheet2.
I want result as shown in column E.
Please help.
Try this version:
Sub polo()
Dim lastrow As Long
Dim sTemp as String
lastrow = Sheets("Sheet1").Range("B" & Rows.Count).End(xlUp).Row
j = 2
For i = 1 To lastrow
If Sheets("Sheet1").Cells(i, 1).Value = "" Then
Sheets("Sheet2").Cells(j, 2).Value = Sheets("Sheet1").Cells(i, 1).Offset(, 1).Value
Sheets("Sheet2").Cells(j, 4).Value = stemp
j = j + 1
Else
stemp = Sheets("Sheet1").Cells(i, 2).Value
End If
Next i
End Sub
I have code that will insert the number of rows based on data missing between 2 numbers but I am unable to figure out the code to get it to copy and paste the years I am missing.
Thanks in advance for any help, I am pretty good at manipulating existing code but I can't find any code to add to this to make it work
Here is the code I have to insert the right number of blank rows
Public Sub Insert()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual 'pre XL97 xlManual
lastRow = ActiveSheet.UsedRange.Rows.Count
ActiveSheet.Cells(lastRow, 1).Select
Set CurrentCell = ActiveSheet.Cells(lastRow, 1)
For n = lastRow To 0 Step -1
If n = lastRow Then GoTo CheckLastRow
If n = 1 Then GoTo CheckfirstRow
ActiveCell.Offset(-2, 0).Select
CheckLastRow:
Set NextCell = CurrentCell.Offset(-1, 0)
ActiveCell.Offset(1, 0).Select
For i = 1 To CurrentCell
ActiveCell.EntireRow.Insert
Next i
Set CurrentCell = NextCell
Next n
'To be performed on the firstrow in the column
CheckfirstRow:
ActiveCell.Offset(-1, 0).Select
For i = 1 To CurrentCell
ActiveCell.EntireRow.Insert
Next i
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
My data looks like this
Column A is number of Rows I need Column B&C has years
B = 2009
C = 2013
It would need the output to copy the line and look like
2009 2010
2010 2011
2011 2012
2012 2013
I added this to the code and I still only have blank lines
Public Sub InsertTest()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual 'pre XL97 xlManual
lastRow = ActiveSheet.UsedRange.Rows.Count
ActiveSheet.Cells(lastRow, 1).Select
Set CurrentCell = ActiveSheet.Cells(lastRow, 1)
For n = lastRow To 0 Step -1
If n = lastRow Then GoTo CheckLastRow
If n = 1 Then GoTo CheckfirstRow
ActiveCell.Offset(-2, 0).Select
CheckLastRow:
Set NextCell = CurrentCell.Offset(-1, 0)
ActiveCell.Offset(1, 0).Select
For i = 1 To CurrentCell
ActiveCell.EntireRow.Insert
Next i
With Worksheets("Sheet1")
newYear = .Cells(n, 2).Value
YearDifference = .Cells(n, 3).Value - newYear
For j = 0 To YearDifference - 1
.Cells(n + j, 2).Value = newYear
newYear = newYear + 1
.Cells(n + j, 3).Value = newYear
Next j
End With
Set CurrentCell = NextCell
Next n
'To be performed on the firstrow in the column
CheckfirstRow:
ActiveCell.Offset(-1, 0).Select
For i = 1 To CurrentCell
ActiveCell.EntireRow.Insert
Next i
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
TESTED
First off, you should always avoid using Select and ActiveCell as described here.
Try adding the following loop before your Set CurrentCell = NextCell line:
With Worksheets("Sheet1")
newYear = .Cells(n, 2).Value
YearDifference = .Cells(n, 3).Value - newYear
For j = 0 To YearDifference - 1
.Cells(n + j, 1).Value = .Cells(n, 1).Value
.Cells(n + j, 2).Value = newYear
newYear = newYear + 1
.Cells(n + j, 3).Value = newYear
Next j
End With
You'll need to change the sheet reference as necessary and you should dimension the variables at the beginning of your code.
EDIT
Replace your code with this and it should work:
Sub InsertTest()
Dim LastRow As Long
Dim newYear As Long
Dim YearDifference As Long
Dim n As Long, j As Long
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
With Worksheets("Sheet1")
LastRow = .Cells(Rows.Count, 2).End(xlUp).Row
For n = LastRow To 1 Step -1
If n Mod 10 = 0 Then DoEvents
If .Cells(n, 1).Value <> "" Then
newYear = .Cells(n, 2).Value
YearDifference = .Cells(n, 3).Value - newYear
If YearDifference > 1 Then
Application.StatusBar = "Updating Row #" & n
.Range(.Cells(n + 1, 1), .Cells(n + YearDifference - 1, 15)).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
For j = 0 To YearDifference - 1
.Rows(n + j).Value = .Rows(n).Value
.Cells(n + j, 2).Value = newYear
newYear = newYear + 1
.Cells(n + j, 3).Value = newYear
Next j
End If
End If
Next n
End With
Application.StatusBar = False
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
EDIT 2 - The code now includes a DoEvents line that runs every 10 iterations. This frees up some resources so that the code will run in the background. For a sheet with 27,000 rows like yours, it may take a couple hours to run the code, but you should be able to do other things in the meantime. I've also added a line to update the status bar so you can see which row the code is on.