I try to copy the headers who have the cell below with "mandatory" value but my Macro stop at the first cell.
Name Phone Houe no Locality
mandatory mandatory
Dim i As Long, j As Long, Lastrow1 As Long, Lastcol1 As Long
Dim mandatory As String
'Lastrow1 = Sheets("sheet3").Range("A" & Rows.Count).End(xlUp).Row
Lastcol1 = Sheets("sheet3").Cells(1 & Columns.Count).End(xlToLeft).Column
For i = 1 To Lastcol1
Sheets("sheet4").Activate
Lastcol2 = Sheets("sheet4").Cells(1 & Columns.Count).End(xlToLeft).Column
For j = 1 To Lastcol2
If Sheets("sheet3").Cells(2, i).Value = "mandatory" Then
Sheets("sheet3").Activate
Sheets("sheet3").Cells(i, "A").Copy
Sheets("sheet4").Activate
Sheets("sheet4").Cells(j, "A").Select
ActiveSheet.Paste
End If
Next j
Application.CutCopyMode = False
Next i
Sheets("sheet3").Activate
Sheets("sheet3").Range("A1").Select
End Sub
As in addition to what has been said above in the comments, You are setting j to a column count of 0 by looking in an empty cells for the end.
use this:
Dim i As Long, j As Long, Lastrow1 As Long, Lastcol1 As Long
Lastcol1 = Sheets("sheet3").Cells(1 , Columns.count).End(xlToLeft).Column
For i = 1 To Lastcol1
j = Sheets("sheet4").Cells(1 , Columns.count).End(xlToLeft).Offset(, 1).Column
if j = 2 and Sheets("sheet4").Cells(1,j-1).value ="" then j=1
If ucase(Sheets("sheet3").Cells(2, i).Value) = "MANDATORY" Then
Sheets("sheet3").Cells(1, i).Copy Sheets("sheet4").Cells(1,j)
End If
Application.CutCopyMode = False
Next i
Sheets("sheet3").Range("A1").Select
And by the fact that you are going cell by cell instead of copying you can just make the new cell value equal to the old cell value.
Sheets("sheet4").Cells(1,j).value = Sheets("sheet3").Cells(1, i).value
Related
This code is running perfectly fine on inserting blank rows based on a cell value, but now I need to also fill out those new rows in range("E") saying "False". Not sure how to make this work.
Sub Procedure1()
Dim i As Integer
Dim LastRow As Long
LastRow = Sheets("Sheet1").Cells(Rows.Count, "F").End(xlUp).Row
For i = LastRow To 2 Step -1
a = Sheets("Sheet1").Cells(i, 8).Value
For j = 1 To a
Sheets("Sheet1").Rows(i + 1).Select
Selection.Insert Shift:=xlDown
Next
Next
Sheets("Sheet1").Cells(i, 1).Select
End Sub
Any thoughts?
You can avoid the inner loop using Resize.
And you can generally avoid Select.
Sub Procedure1()
Dim i As Long, j As Long
Dim LastRow As Long
Dim a
With Sheets("Sheet1")
LastRow = .Cells(Rows.Count, "F").End(xlUp).Row
For i = LastRow To 2 Step -1
a = .Cells(i, 8).Value 'best to check this is a number before going further
.Rows(i + 1).Resize(a).Insert Shift:=xlDown
.Range("E" & i + 1).Resize(a).Value = "False"
Next
End With
End Sub
I'm putting together a list generator and I'm having trouble getting my code to work properly (again!).
The code works for the first row of data but ignores all the others.
All the codes are the same, I've got 5 buttons. The Level # is stored in column X, so #24.
I want to be able to click the button and generate a list of the rows that contain the Level #, from the PI sheet to the Lists sheet.
The data that will be transferred is contact info and sizing info and is in the same row as the Level #.
Private Sub CommandButton2_Click() 'level 1 button
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("PI")
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
'first row number where you need to paste values in Sheet1'
With Worksheets("Lists")
j = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
End With
For i = 1 To LastRow
With Worksheets("PI")
If .Cells(i, 24).Value = "1" Then
.Rows(i).Copy Destination:=Worksheets("Lists").Range("A" & j)
j = j + 1
End If
End With
Next i
End Sub
Private Sub Level5_Click()
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("PI")
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
'first row number where you need to paste values in Sheet1'
With Worksheets("Lists")
j = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
End With
For i = 1 To LastRow
With Worksheets("PI")
If .Cells(i, 24).Value = "5" Then
.Rows(i).Copy Destination:=Worksheets("Lists").Range("A" & j)
j = j + 1
End If
End With
Next i
End Sub
Private Sub Lvl2_Click()
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("PI")
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
'first row number where you need to paste values in Sheet1'
With Worksheets("Lists")
j = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
End With
For i = 1 To LastRow
With Worksheets("PI")
If .Cells(i, 24).Value = "2" Then
.Rows(i).Copy Destination:=Worksheets("Lists").Range("A" & j)
j = j + 1
End If
End With
Next i
End Sub
Private Sub Lvl3_Click()
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("PI")
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
'first row number where you need to paste values in Sheet1'
With Worksheets("Lists")
j = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
End With
For i = 1 To LastRow
With Worksheets("PI")
If .Cells(i, 24).Value = "3" Then
.Rows(i).Copy Destination:=Worksheets("Lists").Range("A" & j)
j = j + 1
End If
End With
Next i
End Sub
Private Sub Lvl4_Click()
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("PI")
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
'first row number where you need to paste values in Sheet1'
With Worksheets("Lists")
j = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
End With
For i = 1 To LastRow
With Worksheets("PI")
If .Cells(i, 24).Value = "4" Then
.Rows(i).Copy Destination:=Worksheets("Lists").Range("A" & j)
j = j + 1
End If
End With
Next i
End Sub
I need some help for my code. I want to copy client's name on column C based on these 2 conditions if:
Macro find value = "ongoing" on Column G
Macro find value = "Istry" on column D
In other words if macro find "ongoing" and "istry" at same row, it will copy automatically the client's name associated with these 2 values asked on another sheet.
I wrote a code but when I tried to run it, I didn't get any result on my sheet.
Sub Ss()
Dim finalrow As Long, i As Long, rowpt As Long, colpt As Long
finalrow = ShSReturn.Range("D" & "G" & Rows.Count).End(xlUp).Row
rowpt = ShPPT.Cells(Rows.Count, 1).End(xlUp).Row
colpt = ShPPT.Cells(Rows.Count, 1).End(xlUp).Row
Call Entry_Point
For i = 7 To finalrow
If ShSReturn.Cells(i, 4).Value = "Istry" & ShSReturn.Cells(i, 7).Value = "Ongoing" Then
ShSReturn.Cells(i, 3).Copy
ShPPT.Cells(rowpt + 6, 12).PasteSpecial xlPasteValues
rowpt = rowpt + 1
colpt = colpt + 1
End If
Next i
End Sub
Making some assumptions here about your intent for this code here is a quick rewrite:
Sub Ss()
Dim finalrow As Long, i As Long, rowpt As Long, colpt As Long
'Determine how many rows we need to loop:
finalDRow = ShSReturn.Range("D" & Rows.Count).End(xlUp).Row
finalGRow = ShSReturn.RAnge("G" & Rows.Count).End(xlUp).Row
'Loop only through rows were both G and D have records
If finalDRow < finalGRow Then finalrow = finalDRow Else finalRow = finalGRow
'I don't know what these two are doing, but they will return the same exact number (the last row populated in column A of whatever worksheet object is in ShPPT
rowpt = ShPPT.Cells(Rows.Count, 1).End(xlUp).Row
colpt = ShPPT.Cells(Rows.Count, 1).End(xlUp).Row
Call Entry_Point
'Loop through rows 7 to whatever finalRow shakes out to be above
For i = 7 To finalrow
'If column D is "Istry" AND column G is "Ongoing" Then execute this code.
If ShSReturn.Cells(i, 4).Value = "Istry" AND ShSReturn.Cells(i, 7).Value = "Ongoing" Then
ShSReturn.Cells(i, 3).Copy
ShPPT.Cells(rowpt + 6, 12).PasteSpecial xlPasteValues
rowpt = rowpt + 1
colpt = colpt + 1
End If
Next i
End Sub
You can use a Filter.
Be sure to set the appropriate worksheet references.
As written, the code copies the entire row, but you can easily modify it if you only want a few fields to be copied over.
Option Explicit
Option Compare Text
Sub filterName()
Const strG = "ongoing"
Const strD = "lstry"
Dim rCopyTo As Range
Dim rData As Range
Dim lastRow As Long, LastCol As Long
With Worksheets("Sheet6")
lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
Set rData = .Range(.Cells(1, 1), .Cells(lastRow, LastCol))
End With
Set rCopyTo = Worksheets("sheet7").Cells(1, 1)
Application.ScreenUpdating = False
rData.AutoFilter field:=4, Criteria1:=strD, visibledropdown:=False
rData.AutoFilter field:=7, Criteria1:=strG, visibledropdown:=False
rCopyTo.Cells.Clear
rData.SpecialCells(xlCellTypeVisible).Copy rCopyTo
rData.Worksheet.AutoFilterMode = False
Application.ScreenUpdating = True
End Sub
I'm a total novice with VBA. I have the following code which does a matching exercise and then pastes the relevant values into col. B. my issue is each time the code is used the col will change how can I add this to the module so that it looks for the last cell used in row 1 and pastes the values below.
Sub TransferData()
Dim i As Long, j As Long, lastrow1 As Long, lastrow2 As Long
Dim myname As String
Application.ScreenUpdating = False
lastrow1 = Sheets("Input Sheet").Range("B" & Rows.Count).End(xlUp).Row
For i = 2 To lastrow1
myname = Sheets("Input Sheet").Cells(i, "B").Value
Sheets("Data").Activate
lastrow2 = Sheets("Data").Range("A" & Rows.Count).End(xlUp).Row
For j = 2 To lastrow2
If Sheets("Data").Cells(j, "A").Value = myname Then
Sheets("Input Sheet").Activate
Sheets("Input Sheet").Cells(i, "c").Copy
Sheets("Data").Activate
Sheets("Data").Cells(j, "B").Select
ActiveSheet.PasteSpecial
End If
Next j
Application.CutCopyMode = False
Next i
Application.ScreenUpdating = True
End Sub
any assistance with this would be appreciated.
You can replace your second For j = 2 To lastrow2 with the Match function.
Also, there is no need to Activate the sheets back and fourth all the time, just use fully qualified Ranges instead.
Code
Option Explicit
Sub TransferData()
Dim i As Long, j As Long, lastrow1 As Long, lastrow2 As Long
Dim myname As String
Dim MatchRng As Range
Application.ScreenUpdating = False
j = 2
With Sheets("Input Sheet")
lastrow1 = .Range("B" & .Rows.Count).End(xlUp).Row
' the 2 lines bellow should be outisde the loop
lastrow2 = Sheets("Data").Range("A" & Sheets("Data").Rows.Count).End(xlUp).Row
Set MatchRng = Sheets("Data").Range("A2:A" & lastrow2)
For i = 2 To lastrow1
myname = .Range("B" & i).Value
If Not IsError(Application.Match(myname, MatchRng, 0)) Then '<-- if successful Match
Sheets("Data").Range("B" & j).Value = .Range("C" & i).Value
j = j + 1
End If
Application.CutCopyMode = False
Next i
End With
Application.ScreenUpdating = True
End Sub
I have the code below which takes a table of data, removes most of the columns and any rows where the value in column C is zero, and finally sorts by column C.
What I need to be able to do next is find the row where the values in column C change from positive to negative and insert 5 blank rows.
I can find other code examples which loop through the values to perform a number of tasks but I just need insert rows where the values change from positive to negative.
Sub FormatData()
Dim wsData As Worksheet
Dim FirstRow As Integer
Dim LastRow As Integer
Dim LastRow2 As Integer
Dim lrow As Integer
Set wsData = Worksheets("Data")
FirstRow = wsData.Range("C2").Row
LastRow = wsData.Range("A" & Rows.Count).End(xlUp).Row
Columns("C:Y").Select
Selection.Delete Shift:=xlToLeft
Columns("D:F").Select
Selection.Delete Shift:=xlToLeft
wsData.Range("C2:C" & LastRow).Select
For lrow = LastRow To FirstRow Step -1
Set workrange = Cells(lrow, 3)
If workrange.Value = "0" _
Then workrange.EntireRow.Delete
Next lrow
LastRow2 = wsData.Range("C" & Rows.Count).End(xlUp).Row
Range("A2:C" & LastRow2).Sort Key1:=Range("C2:C" & LastRow2), Order1:=xlDescending, Header:=xlNo
End Sub
You can add something like the following loop to the end of your sub after your sorting code:
FirstRow = wsData.Range("C2").Row
LastRow = wsData.Range("C" & Rows.Count).End(xlUp).Row
For lrow = FirstRow To LastRow
If wsData.Cells(lrow, 3).Value >= 0 And wsData.Cells(lrow + 1, 3).Value <= 0 Then
For x = 1 To 5
wsData.Rows(lrow + 1).Insert shift:=xlShiftDown
Next x
Exit For
End If
Next lrow