I would like to be able to copy the selected row from sheet 3 range B: G and paste the cells to sheet 4 column A: F
but when the operation ends I find the formatting in the A: F range and the pasted data in the B: G range Thanks
Sub Elimina_selezione()
Worksheets(3).Activate
ActiveSheet.Unprotect
Call copia_archivio
Worksheets(3).Activate
ActiveCell.EntireRow.Delete
Sheets(3).Protect
End Sub
Sub copia_archivio()
Dim i As Range
Dim rig As Long
Sheets(3).Select
ActiveCell.EntireRow.Copy
Worksheets(4).Activate
ActiveSheet.Unprotect
With Sheets(4).Range("A" & Rows.Count).End(xlUp).Offset(1)
.PasteSpecial Paste:=xlPasteValues, Transpose:=False
With Intersect(.EntireRow, .Parent.Columns("A:F"))
.Interior.ColorIndex = 44
.Borders.LineStyle = XlLineStyle.xlContinuous
End With
End With
End Sub
Better to use range and worksheet variables where possible. The only activation necessary is to get the selection on sheet3, I think. (tested code)
Sub CopyRowFromSheet3to4andDeleteRow()
Dim wb As Workbook: Set wb = ThisWorkbook
Dim wsSrc As Worksheet: Set wsSrc = wb.Worksheets("Sheet3")
Dim wsTgt As Worksheet: Set wsTgt = wb.Worksheets("Sheet4")
wsSrc.Activate 'need to activate it to get its selected range
Dim rSel As Range: Set rSel = wb.Windows(1).Selection 'window(1) is always the active worksheet
Dim iSelRow As Long: iSelRow = rSel.Row
Dim rSrc As Range: Set rSrc = wsSrc.Range("B" & iSelRow & ":G" & iSelRow)
Dim iTgtRow As Long: iTgtRow = wsTgt.Range("A" & wsTgt.Rows.Count).End(xlUp).Row + 1
Dim rTgt As Range: Set rTgt = wsTgt.Range("A" & iTgtRow & ":F" & iTgtRow)
rSrc.Copy rTgt
rTgt.Interior.ColorIndex = 44
rTgt.Borders.LineStyle = XlLineStyle.xlContinuous
Dim rDelSrcRow As Range: Set rDelSrcRow = wsSrc.Range(iSelRow & ":" & iSelRow)
rDelSrcRow.Delete xlShiftUp
End Sub
You are saying that you copy the selected row from sheet 3 range B: G. As far as I understand you are trying to copy not the whole row but only the range of intersection with columns b:g. But your code copies the whole row starting from column A, not B.
You should re-code the range you want to copy and replace "activecell.entirerow" with it.
Related
screenshot of code
I am trying to calculate sum in cell "I13" of sheet2 with inputs based on the dynamic range.
Formula
range("I13").formula= "=sum('sheet1'!A1:A3)"
works but the range can be dynamic. For this I have used lr to identify the last row in the range
lr=cells(rows.count,1).end(xlup).row
Now, I want to modify the above formula such that in place of A3, it takes last cell. i.e. A&lr
Have tried using range("I13").formula= "=sum('sheet1'!A1:A"&lr)", but it results in error
Sub MMM()
Windows("Template.xlsx").activate
sheets("sheet1").select
range("a1").select
lr=cells(rows.count,1).end(xlup).row
sheets("sheet2").select
'this code works. But want dynamic range
'range("I13").formula = "= SUM('sheet1'!A1:A3)"
range("I13").formula = "= sum('sheet1'!A1:A&lr)"
End Sub
you can try to define the variable:
Option Explicit ' It should be used when you define variable
Sub MMM()
Dim lr as Range ' Define variable
Windows("Template.xlsx").activate
sheets("sheet1").select
range("a1").select
lr=cells(rows.count,1).end(xlup).row
sheets("sheet2").select
range("I13").formula = "= sum('sheet1'!A1:A&lr)"
End Sub
You have to join the string for the formula like this:
"=SUM('Sheet1'!A1:A" & lastRow & ")"
Alternatively:
If you set the whole range to be summed then you can use the Address of this range. The External-parameter returns the sheet name as well.
Sub MMM()
Dim wb As Workbook: Set wb = ThisWorkbook
Dim wsSource As Worksheet: Set wsSource = wb.Worksheets("Sheet1")
Dim wsTarget As Worksheet: Set wsTarget = wb.Worksheets("Sheet2")
Dim rgDataToSum As Range
With wsSource
Set rgDataToSum = .Range("A1", .Cells(.Rows.Count, 1).End(xlUp))
End With
wsTarget.Range("I13").Formula = "=SUM(" & rgDataToSum.Address(True, True, External:=True) & ")"
End Sub
I am building out a workbook where every sheet is for a different stage of a software installation. I am trying to aggregate the steps that fail by copying my fail rows into a summary sheet. I finally got them to pull, but they are pulling into the new sheet on the same row # as they are located in the original sheet.
Here is what I am using now:
Option Explicit
Sub Test()
Dim Cell As Range
With Sheets(7)
' loop column H untill last cell with value (not entire column)
For Each Cell In .Range("D1:D" & .Cells(.Rows.Count, "D").End(xlUp).Row)
If Cell.Value = "Fail" Then
' Copy>>Paste in 1-line (no need to use Select)
.Rows(Cell.Row).Copy Destination:=Sheets(2).Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
End If
Next Cell
End With
End Sub
I need to:
Pull row that has cell containing "Fail"
Copy row into master starting at Row 4 and consecutively down without overwriting
Run across all sheets at once-
*(they are named per step of install - do i need to rename to "sheet1, sheet2, etc"????)
When macro is run clear previous results (to avoid duplicity)
Another user offered me an autofilter macro but it is failing on a 1004 at this line ".AutoFilter 4, "Fail""
Sub Filterfail()
Dim ws As Worksheet, sh As Worksheet
Set sh = Sheets("Master")
Application.ScreenUpdating = False
'sh.UsedRange.Offset(1).Clear 'If required, this line will clear the Master sheet with each transfer of data.
For Each ws In Worksheets
If ws.Name <> "Master" Then
With ws.[A1].CurrentRegion
.AutoFilter 4, "Fail"
.Offset(1).EntireRow.Copy sh.Range("A" & Rows.Count).End(3)(2)
.AutoFilter
End With
End If
Next ws
Application.ScreenUpdating = True
End Sub
Try this:
The text “Completed” in this xRStr = "Completed" script indicates the specific condition that you want to copy rows based on;
C:C in this Set xRg = xWs.Range("C:C") script indicates the specific column where the condition locates.
Public Sub CopyRows()
Dim xWs As Worksheet
Dim xCWs As Worksheet
Dim xRg As Range
Dim xStrName As String
Dim xRStr As String
Dim xRRg As Range
Dim xC As Integer
On Error Resume Next
Application.DisplayAlerts = False
xStr = "New Sheet"
xRStr = "Completed"
Set xCWs = ActiveWorkbook.Worksheets.Item(xStr)
If Not xCWs Is Nothing Then
xCWs.Delete
End If
Set xCWs = ActiveWorkbook.Worksheets.Add
xCWs.Name = xStr
xC = 1
For Each xWs In ActiveWorkbook.Worksheets
If xWs.Name <> xStr Then
Set xRg = xWs.Range("C:C")
Set xRg = Intersect(xRg, xWs.UsedRange)
For Each xRRg In xRg
If xRRg.Value = xRStr Then
xRRg.EntireRow.Copy
xCWs.Cells(xC, 1).PasteSpecial xlPasteValuesAndNumberFormats
xC = xC + 1
End If
Next xRRg
End If
Next xWs
Application.DisplayAlerts = True
End Sub
Here's another way - You'll have to assign your own Sheets - I used 1 & 2 not 2 & 7
Sub Test()
Dim xRow As Range, xCel As Range, dPtr As Long
Dim sSht As Worksheet, dSht As Worksheet
' Assign Source & Destination Sheets - Change to suit yourself
Set sSht = Sheets(2)
Set dSht = Sheets(1)
' Done
dPtr = Sheets(1).Rows.Count
dPtr = Sheets(1).Range("D" & dPtr).End(xlUp).Row
For Each xRow In sSht.UsedRange.Rows
Set xCel = xRow.Cells(1, 1) ' xCel is First Column in Used Range (May not be D)
Set xCel = xCel.Offset(0, 4 - xCel.Column) ' Ensures xCel is in Column D
If xCel.Value = "Fail" Then
dPtr = dPtr + 1
sSht.Rows(xCel.Row).Copy Destination:=dSht.Rows(dPtr)
End If
Next xRow
End Sub
I think one of the problems in your own code relates to this line
.Rows(Cell.Row).Copy Destination:=Sheets(2).Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
The section Rows.Count, "A" should be referring to the destination sheet(2) but isn't because of the line
With Sheets(7)
further up
i have 2 sheets , in sheet1 i have a column with article names(im geeting my names from sheet1) , in sheet 2 i have a column like that two "Nom de l'entité" (doing a search by header in sheet 2), if i find a match in sheet 2 , i look for a column called "longueur" and copy the value and put it in the offset(0,1) of the article name in sheet 1 . Im a beginner but this is what i did so far.I need to loop through all the article names hoping to fin them all in sheet 2 . Here's a link of photo to see what im trying to do exactly : https://postimg.cc/pmLY9dXc
Sub longueur()
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Lecture") '<== Sheet that has raw data
Dim wss As Worksheet: Set wss = ThisWorkbook.Sheets("Feuil1") 'sheet that we re gonna paste longueur into
Dim FoundName As Range, FoundLongueur As Range
Dim c As Range
Set FoundName = ws.Range("A1:DS1").Find("NOM DE L'ENTITÉ") '<== Header name to search for
Set FoundLongueur = ws.Range("A1:DS1").Find("LONGUEUR") '<== Header name to search for in case we already found name match
If Not FoundName Is Nothing And Not FoundLongueur Is Nothing Then
For Each c In Range(wss.Cells.Range("D:D")) 'go back to sheet1 to get the names to search for
If c.value = FoundName Then
FoundLongueur.Offset(0, 1).value
End If
Next c
End If
End Sub
Try
Option Explicit
Sub longueur()
Dim wb As Workbook, ws1 As Worksheet, ws2 As Worksheet
Dim rngName As Range, rng As Range, c As Range
Dim colLongueur As Integer, iLastRow As Long
Set wb = ThisWorkbook
Set ws1 = wb.Sheets("Feuil1") 'sheet that we re gonna paste longueur into
Set ws2 = wb.Sheets("Lecture") '<== Sheet that has raw data
' find column NOM DE L'ENTITÉ on sheet 2
Set rng = ws2.Range("A1:DS1").Find("NOM DE L'ENTITÉ")
If rng Is Nothing Then
MsgBox "Could not find 'NOM DE L'ENTITÉ' on " & ws2.Name, vbCritical
Exit Sub
End If
' expand to end of column
Set rngName = ws2.Range(rng, ws2.Cells(Rows.Count, rng.Column).End(xlUp))
' find column LONGUEUR on sheet 2
Set rng = ws2.Range("A1:DS1").Find("LONGUEUR")
If rng Is Nothing Then
MsgBox "Could not find 'LONGUEUR' on " & ws2.Name, vbCritical
Exit Sub
End If
colLongueur = rng.Column
' scan sheet 1 col D
iLastRow = ws1.Cells(Rows.Count, "D").End(xlUp).Row
For Each c In ws1.Range("D1:D" & iLastRow)
' find name on sheet 2
Set rng = rngName.Find(c.Value, LookIn:=xlValues, LookAt:=xlWhole)
If rng Is Nothing Then
c.Offset(0, 1).Value = "No Match"
Else
' copy value from column LONGUEUR
c.Offset(0, 1).Value = ws2.Cells(rng.Row, colLongueur)
End If
Next
MsgBox "Ended"
End Sub
I am trying to select rows in a table based on the word "Yes" being present in column J.
I have a table going from column A to J, and I want to select the rows where there is a "Yes" in column J and paste only those rows into a new sheet.
Once selected, I need to copy these rows to a new sheet or word document.
I have tried a range of forumulas, this is for Windows MS Excel software, using a VBA Macro.
I am using the following VBA, but having issues:
Sub Macro1()
Dim rngJ As Range
Dim cell As Range
Set rngJ = Range("J1", Range("J65536").End(xlUp))
Set wsNew = ThisWorkbook.Worksheets.Add
For Each cell In rngJ
If cell.Value = "Yes" Then
cell.EntireRow.Copy
wsNew.Sheets("Sheet1").Range("J65536").End(xlUp).Offset(1, 0).Select
ActiveSheet.Paste
End If
Next cell
End Sub
Any help would be very much appreciated!
Rather than finding, copying and pasting for each cell, why not find all, then copy and paste once like this:
Sub Macro1()
Dim rngJ As Range
Dim MySel As Range
Set rngJ = Range("J1", Range("J" & Rows.Count).End(xlUp))
Set wsNew = ThisWorkbook.Worksheets.Add
For Each cell In rngJ
If cell.Value = "Yes" Then
If MySel Is Nothing Then
Set MySel = cell.EntireRow
Else
Set MySel = Union(MySel, cell.EntireRow)
End If
End If
Next cell
If Not MySel Is Nothing Then MySel.Copy Destination:= wsNew.Range("A1")
End Sub
It's better to avoid using Select as much as possible; see this link.
Use something like this
Option Explicit
Public Sub CopyYesRowsToNewWorksheet()
Dim wsSource As Worksheet
Set wsSource = ThisWorkbook.ActiveSheet 'better define sheet by name ThisWorkbook.Worksheets("SourceSheet")
Dim DataRangeJ As Variant 'read "yes" data into array for faster access
DataRangeJ = wsSource.Range("J1", wsSource.Range("J" & wsSource.Rows.Count).End(xlUp)).Value
Dim wsNew As Worksheet
Set wsNew = ThisWorkbook.Worksheets.Add
Dim NextFreeRow As Long
NextFreeRow = 1 'start pasting in this row in the new sheet
If IsArray(DataRangeJ) Then
Dim iRow As Long
For iRow = LBound(DataRangeJ) To UBound(DataRangeJ) 'loop through data array
If DataRangeJ(iRow, 1) = "yes" Then
wsNew.Rows(NextFreeRow).Value = wsSource.Rows(iRow).Value 'copy the values of the row
NextFreeRow = NextFreeRow + 1
End If
Next iRow
ElseIf DataRangeJ = "yes" Then 'if only the first row has data
wsNew.Rows(NextFreeRow).Value = wsSource.Rows(1).Value
End If
End Sub
The line
wsNew.Rows(NextFreeRow).Value = wsSource.Rows(iRow).Value
only copys the value without formatting. If you also want to copy the formatting replace it with
wsSource.Rows(iRow).Copy Destination:=wsNew.Rows(NextFreeRow)
I am stuck writing this Excel macro and could kindly use some help. I am trying to create a dynamic macro that will compare two tables in two different sheets and will update information for a row if different or copy a new row to the new table if not there. Both tables contain the same columns of info and have a unique product code per data row. Once a button is pressed, if the product code for the row in table1 is not found on the new table then that row will copy. If the product code is found in the new table but other information in columns is different, than that other information will be updated on the new table. If the product code is found and the other information is the same then that row will not be copied. I need this for as many lines as possible in table1.
NOTE: I thought VLOOKUP may be the route to successfully code this macro...BELOW is my attempt so far to get this to work.
Sub Copy_Attempt()
Application.ScreenUpdating = False
Dim s1 As Worksheet, s2 As Worksheet
Set s1 = Sheets("Raw Data")
Set s2 = Sheets("BAS Linkage Master")
Dim i As Integer
Dim j As Integer
Dim Proj_ID As String
Dim Lookup_Range As Range
Dim Linkage_Lookup_Range As Range
Dim Raw_Percent_Complete As String
Dim Linkage_Percent_Complete As String
Set Lookup_Range = s1.Range("A1:O1000")
Set Linkage_Lookup_Range = s2.Range("A6:N1000")
For i = 2 To 1000
Proj_ID = s1.Range("F" & i).Value
Raw_Percent_Complete = Application.WorksheetFunction.VLookup(Proj_ID, Lookup_Range, 10, False)
Next
For j = 7 To 1000
Linkage_Percent_Complete = s2.Range("I" & j).Value
Next
If Raw_Percent_Complete = Linkage_Percent_Complete Then
' DO NOT COPY THAT ROW OVER
Else
Percent_Complete = Range("I" & j).Value
'UPDATE PERCENT COMPLETE FOR THAT SPECIFIC PRODUCT CODE
End If
Sheets("Raw Data").Activate
Columns("H").EntireColumn.Delete
Range("A2:P1000").Select
Selection.Copy
Sheets("BAS Linkage Master").Activate
Range("A" & Rows.Count).End(xlUp).Offset(1).Select
Selection.PasteSpecial
' Sheets("Welcome").Activate
' Range("A11:O11").ClearContents
Sheets("Raw Data").Activate
Range("A2:N10000").ClearContents
Application.CutCopyMode = False
Application.ScreenUpdating = True
Sheets("BAS Linkage Master").Activate
End Sub
This is a nice little script that looks for differences and highlights the differences.
Public Sub CompareSheets()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim cell As Range, rng As Range
Set ws1 = Worksheets("Sheet1")
Set ws2 = Worksheets("Sheet2")
Set rng = ws1.Range("A1:B20")
For Each cell In rng
Celladdress = cell.Address
If cell <> ws2.Range(Celladdress) Then
cell.Interior.Color = vbYellow
ws2.Range(Celladdress).Interior.Color = vbYellow
End If
Next cell
End Sub
You can use the same concept to copy the values from one table to another.
Public Sub CompareSheets()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim cell As Range, rng As Range
Set ws1 = Worksheets("Sheet1")
Set ws2 = Worksheets("Sheet2")
Set rng = ws1.Range("A1:B20")
For Each cell In rng
Celladdress = cell.Address
If cell <> ws2.Range(Celladdress) Then
ws2.Range(Celladdress).Value = ws1.Range(Celladdress).Value
End If
Next cell
End Sub