Actually I have converted a pdf to excel. After conversion the next line is converted in next row. I want to merge contents on following condition.
If row1 & row2 has text then put contents of row2 in row1 (in addition to existing) and clear contents of row2. If row2 is blank it should keep contents of row1 and move on to next row.
I have tried two macros. But they are not giving desired output
Sub cc()
Dim X As Integer
For X = 1 To 500
'If Sheet2.Cells(X + 1, 1) isNotBlank Then
If Not IsEmpty(Sheet2.Cells(X + 1, 1).Value) And Not IsEmpty(Sheet2.Cells(X, 1).Value) Then
Sheet2.Cells(X + 1, 1).ClearContents
End If
Next
End Sub
Sub ccc()
Dim X As Integer
For X = 1 To 500
'If Sheet2.Cells(X + 1, 1) isNotBlank Then
If Not IsEmpty(Sheet2.Cells(X + 1, 1).Value) And Not IsEmpty(Sheet2.Cells(X, 1).Value) Then
If Not IsEmpty(Sheet2.Cells(X, 1).Value) Then
Sheet2.Cells(X, 1).Value = Sheet2.Cells(X, 1)
Sheet2.Cells(X + 1, 1).ClearContents
End If
Next
End Sub
Related
So I have the above code, I want to continue on this logic: if K4 is not empty then copy L3 to L4 and so on, until one cell is empty (for example K32 is not empty then copy L31 to L32, but if K33 is empty then stop)
Im sorry if this is a basic question, I have just started working with VBA.
Thank you in advance
Sub kepletmasolos()
Sheets("XTR MSTR").Select
If IsEmpty(Range("K3").Value) = False Then
Range("L2").Copy Range("L3")
End If
End Sub
Here is one way, using a Do loop:
Sub kepletmasolos()
Dim r As Long: r = 3
With Sheets("XTR MSTR")
Do Until IsEmpty(.Cells(r, "K"))
'.Cells(r, "L").Value = .Cells(r - 1, "L").Value
.Cells(r - 1, "L").copy .Cells(r, "L")
r = r + 1
Loop
End With
End Sub
new to VBA myself, Just thought i would through my idea in?
row = where you would start, let me know what you think.
Sub kepletmasolos()
Dim Row As Long
Row = 1
Start:
With Sheets("XTR MSTR")
If Not isEmpty(.Cells(Row, "K")) Then
.Cells(Row, "L").Copy .Cells(Row + 1, "L")
Row = Row + 1
GoTo Start
Else
End If
End With
End Sub
I found a code that I use to insert rows based on the cell value:
Sub Add_Rows()
Dim r As Long
Application.ScreenUpdating = False
For r = Range("F" & Rows.count).End(xlUp).Row To 1 Step -1
If Cells(r, "F").Value > 0 Then Rows(r + 1).Resize(Cells(r, "F").Value).Insert
Next r
Application.ScreenUpdating = True
End Sub
But I also need to copy the value of the cell with the same index as "F" into the inserted rows:
How can I modify the code so that rows are inserted based on the value of the range F and a value from the range H is inserted into these rows in parallel?
That is, the script should have logic: if the value of "F" is 2, two rows are inserted - and the value from the index "H" is inserted into these two new rows
In the code that I sent, I manage to insert rows based on the value from the index "F", but I can't supplement the code so that the value from the index H is inserted for each new row
Please tell me how to modify the code?
Thanks
I added a line after the .Insert that assigns the value to the "H" column of those new rows. I used the same dynamic range ideas that .Insert used to find the correct range for those new rows.
Sub Add_Rows()
Dim r As Long
Application.ScreenUpdating = False
For r = Range("F" & Rows.Count).End(xlUp).Row To 1 Step -1
If Cells(r, "F").Value > 0 Then
Rows(r + 1).Resize(Cells(r, "F").Value).Insert
Cells(r + 1, "H").Resize(Cells(r, "F").Value).Value = Cells(r, "H").Value
End If
Next r
Application.ScreenUpdating = True
End Sub
Try something like this:
Sub Add_Rows()
Dim r As Long
Application.ScreenUpdating = False
For r = Range("F" & Rows.Count).End(xlUp).Row To 1 Step -1
If Cells(r, 5).Value > 0 Then
Rows(r + 1).Resize(Cells(r, 5).Value).Insert
' insert h value
Cells(r + 1, 7).Value = Cells(r, 7).Value
End If
Next r
Application.ScreenUpdating = True
End Sub
My data includes headers. In column C, the cells sometimes contain "/" or ",". The goal is to split these cells and insert a new row underneath with every sub-string.
INPUT
OUTPUT
With the code below I have been able to replace all "," with "/". Split the cell in column C by the "/" delimiter and paste underneath. I have not been able to copy and paste the contents of the row underneath with every element in the split function array. It also seems to be pasting the split values beginning in cell C2 every time.
Sub SuspenseReport()
Dim SearchCell As Variant
Dim i As Integer
Dim cell As Range
Application.ScreenUpdating = False
Set Rng = Application.Range("C2:C1000") '*Change Last Row Value Here
vLr = ActiveCell.SpecialCells(xlLastCell).Row
For Each cell In Rng
cell = Replace(cell, ",", "/")
If InStr(1, cell, "/") <> 0 Then
SearchCell = Split(cell, "/")
For i = 0 To UBound(SearchCell)
Cells(i + 2, 2).Value = SearchCell(i)
Next i
End If
Next cell
Application.ScreenUpdating = True
End Sub
When inserting or deleting rows always work from the bottom up. To retain the order of the split value, work from last to first.
Option Explicit
Sub splitSlash()
Dim tmp As Variant, i As Long, j As Long
With Worksheets("sheet1")
.Columns("C").Replace what:=Chr(44), replacement:=Chr(47), lookat:=xlPart
For i = .Cells(.Rows.Count, "A").End(xlUp).Row To 2 Step -1
tmp = Split(.Cells(i, "C").Value2 & Chr(47), Chr(47))
For j = UBound(tmp) - 1 To LBound(tmp) + 1 Step -1
.Cells(i + 1, "A").EntireRow.Insert
.Cells(i + 1, "A") = .Cells(i, "A").Value2
.Cells(i + 1, "B") = .Cells(i, "B").Value2
.Cells(i + 1, "C") = tmp(j)
Next j
.Cells(i, "C") = tmp(j)
Next i
End With
End Sub
This is the macro i am using, it looks at a field (AS) and then depending on the number in that column it will create the same amount of rows underneath. So for example if AS has '4' it will create 4 rows containing the number 4.
I need an amendment to this so that these rows will show 1-4, 2-4, 3-4, 4-4
Sub addlabels()
Dim r As Long
For r = Cells(Rows.Count, 1).End(xlUp).Row To 2 Step -1
If Cells(r, "AS") > 1 Then
Cells(r, 1).EntireRow.Copy
Cells(r + 1, 1).EntireRow.Resize(Cells(r, "AS").Value - 1).Insert shift:=xlDown
End If
Next r
End Sub
Here is an example image of how i need the column to display at the moment it just simply copies from the top field http://i.stack.imgur.com/p8bl8.png
May be you can try like this:
Considering the field("AS") is in cell a1 i've used the following code:
Sub addinglabels()
Dim i As Integer
cellvalue = ActiveSheet.Range("A1").Value
If (cellvalue > 1) Then
For i = 1 To cellvalue
Cells(i + 1, 1).Value = i & "--" & cellvalue
Next i
End If
End Sub
Basically I have 3 worksheets . From the first worksheet I get a value (rotid) , and by using the match function I try to find the value in the second worksheet , and copy the row associated with the value into worksheet 3 where y is the index of the row in sheet 2 which corresponds to the value (rotid). But sometimes a value is not found in worksheet 2 and the program crashes . How can I deal with this error ?
worksheet 1 is list,
worksheet 2 is rotmain2,
worksheet 3 is imdb
btw this is how my code looks like . Im not sure how to use codetags.
Sub combine_imdb_rot_data()
' y is the index of the row in rotmain2 which corresponds to rotid
Dim y As Variant
Sheets("imdbmain").Select
For i = 1 To 4415
' select sheet list and assign rotid for value of the cell in row i+1 and column 7
rotid = Sheets("list").Cells(i + 1, 7).Value
' if rotid is not empty,
If Len(rotid) > 0 Then
'look for a row that corresponds to the rotid in worksheet "rotmain2"
Sheets("rotmain2").Select
'x = Sheets("list").Cells(i + 1, 7).Row
y = WorksheetFunction.Match(rotid, Range("B1:B4218"), 0)
If IsNumeric(y) Then
' copy the information in the row
Range(Cells(y, 1), Cells(y, 13)).Select
Selection.Copy
' paste it into row i+1 in worksheet "imdbmain"
Sheets("imdbmain").Select
'select row i+1 in imdbmain
Range(Cells(i + 1, 9), Cells(i + 1, 21)).Select
Workbooks(1).Sheets(1).Paste
Application.CutCopyMode = False
Else
' copy the information in the row
Range(A4220, M4220).Select
Selection.Copy
' paste it into row i+1 in worksheet "imdbmain"
Sheets("imdbmain").Select
'select row i+1 in imdbmain
Range(Cells(i + 1, 9), Cells(i + 1, 21)).Select
Workbooks(1).Sheets(1).Paste
Application.CutCopyMode = False
End If
End If
Next
End Sub
I also tried with another method suggested by Remou.
Is this how the .find method works ? Im not sure but when I use it I get a Runtime error 13 type mismatch:
Sub combine_imdb_rot_data()
' y is the index of the row in rotmain2 which corresponds to rotid
Dim y As Variant
Sheets("imdbmain").Select
For i = 1 To 4415
' select sheet list and assign rotid for value of the cell in row i+1 and column 7
rotid = Sheets("list").Cells(i + 1, 7).Value
' if rotid is not empty,
If Len(rotid) > 0 Then
'look for a row that corresponds to the rotid in worksheet "rotmain2"
Sheets("rotmain2").Select
'x = Sheets("list").Cells(i + 1, 7).Row
Set y = Range("B1:B4218").Find(rotid)
If y Is Nothing Then
' copy the information in the row
'Range("1:4," & x & ":" & x).Copy
'Range("A&x"&:&"M&x").Copy
'Copy empty row
Range("A101:M101").Select
Selection.Copy
' paste it into row i+1 in worksheet "imdbmain"
Sheets("imdbmain").Select
'select row i+1 in imdbmain
Range(Cells(i + 1, 9), Cells(i + 1, 21)).Select
Workbooks(1).Sheets(1).Paste
Else
' copy the information in the row
'Range("1:4," & x & ":" & x).Copy
'Range("A&x"&:&"M&x").Copy
Range(Cells(y, 1), Cells(y, 13)).Select
Selection.Copy
' paste it into row i+1 in worksheet "imdbmain"
Sheets("imdbmain").Select
'select row i+1 in imdbmain
Range(Cells(i + 1, 9), Cells(i + 1, 21)).Select
Workbooks(1).Sheets(1).Paste
Application.CutCopyMode = False
End If
End If
Next
End Sub
You could trap the error, or perhaps use Find:
rotid=5 ''Let us say
With Worksheets(1).Range("B1:B4218")
''Find returns a range object, so we use Set
Set y = .Find(rotid, LookIn:=xlValues, lookAt:=xlWhole)
If y Is Nothing Then
Debug.Print "Not found"
Else
''This will print a cell, $b$15, for example
Debug.Print y.Address
''This will print 5
Debug.Print y.Value
End If
End With
Futher information: http://msdn.microsoft.com/en-us/library/aa195730%28office.11%29.aspx
The first thing you may want to do is put On Error Resume Next at the top of your module. Give that a try first.