I wrote a code that import a table from an other sheet after filtering some lines.My problem is that when I exceed the number of lines of the table that I have in this sheet it exceeds the table. Now, I want to know if there is a way to modify the size of the table dynamically with the number of lines.
Public Sub refresh()
Dim ws1 As Worksheet, ws2 As Worksheet, lr1 As Long, lRow As Long
Set ws1 = ThisWorkbook.Worksheets("Scénarios de menace")
Set ws2 = ThisWorkbook.Worksheets("Analyse de risque")
Application.Calculation = xlCalculationAutomatic
ws2.Range("B6:N" & ws2.Cells(ws2.Rows.Count, 2).End(xlUp).Row).ClearContents
lr1 = ws1.Cells(ws1.Rows.Count, 2).End(xlUp).Row
ws1.Range("A1:A" & lr1).AutoFilter Field:=1, Criteria1:="x"
ws1.Range("B3:N" & lr1).SpecialCells(xlCellTypeVisible).Copy
ws2.Range("B6").PasteSpecial Paste:=xlPasteValuesAndNumberFormats
ws1.Range("A6:A" & lr1).AutoFilter
ws2.Activate: ws2.Cells(1, 1).Activate
End Sub
The issue is that, to resize a table it is easier when you know it's name.
I've added a 3 lines to your code :
To get the total range used by pasted data
To create a table for that total range
To resize the table (not really useful here as the table was just set)
Public Sub refresh()
Dim ws1 As Worksheet, ws2 As Worksheet, lr1 As Long, lRow As Long, ResultsRange As String
Set ws1 = ThisWorkbook.Worksheets("Scénarios de menace")
Set ws2 = ThisWorkbook.Worksheets("Analyse de risque")
Application.Calculation = xlCalculationAutomatic
ws2.Range("B6:N" & ws2.Cells(ws2.Rows.Count, 2).End(xlUp).Row).ClearContents
lr1 = ws1.Cells(ws1.Rows.Count, 2).End(xlUp).Row
ws1.Range("A1:A" & lr1).AutoFilter Field:=1, Criteria1:="x"
ws1.Range("B3:N" & lr1).SpecialCells(xlCellTypeVisible).Copy
ws2.Range("B6").PasteSpecial Paste:=xlPasteValuesAndNumberFormats
ws1.Range("A6:A" & lr1).AutoFilter
ws2.Activate
ws2.Cells(1, 1).Activate
ResultsRange = "$B$6:$N$" & ws2.Range("B"& ws2.Rows.Count).End(xlUp).Row
ws2.ListObjects.Add(xlSrcRange, Range(ResultsRange), , xlYes).Name = "Results_Table"
ws2.ListObjects("Results_Table").Resize Range(ResultsRange)
End Sub
Related
I wanted to copy data from one sheet to another. The selection part is according to date and specific value of column.
enter image description here
I tried this code from internet. So the basic logic is if 2 condition are met then copy the row. However its not working.
It actually working first when only one condition are written, when the second one written, the VBA did not do anything
Sub CopyRowsAcross()
Dim i As Integer
Dim ws1 As Worksheet: Set ws1 = ThisWorkbook.Sheets("Clean_Sheet")
Dim ws2 As Worksheet: Set ws2 = ThisWorkbook.Sheets("Daily_Report")
For i = 2 To ws1.Range("P65536").End(xlUp).Row
If ws1.Cells(i, 1) = "DOWNY S.FRESH 900ML" and ws2.Range ("C2") = ws1.Cells(i,3) Then
ws1.Rows(i).Copy ws2.Rows(ws2.Cells(ws2.Rows.Count, 2).End(xlUp).Row + 1)
End If
Next i
End Sub
the ws2.Range("C2") are selected date written in cell C2 in the sheet.
The result are the row copied based on this 2 criteria
This works assuming both your data in worksheet 1 are really dates and the filter in C2 is a date also:
Option Explicit
Sub CopyRowsAcross()
Dim LastRow As Long, lrow As Long
Dim ws1 As Worksheet: Set ws1 = ThisWorkbook.Sheets("Clean_Sheet")
Dim ws2 As Worksheet: Set ws2 = ThisWorkbook.Sheets("Daily_Report")
Dim DateFilter As Date
With ws2
DateFilter = .Cells(2, 3)
lrow = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
End With
With ws1
LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
.Range("A1:C" & LastRow).AutoFilter Field:=1, Criteria1:="DOWNY S.FRESH 900ML"
.Range("A1:C" & LastRow).AutoFilter Field:=3, Criteria1:=Format(DateFilter, "dd-Mmm-yy")
LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
If LastRow > 1 Then
.Range("A2:C" & LastRow).SpecialCells(xlCellTypeVisible).Copy ws2.Cells(lrow, 1)
End If
.AutoFilterMode = False
End With
End Sub
Instead of looping (Time consuming) you could just filter the data you need and copy it all a t once.
I have made a macro that copies two dynamic table columns from one worksheet to another. On the Second worksheet I want to subtract those two columns and paste the result on a separate column/vector. All of this needs to be dynamic since I plan on running the macro once a day.
The closest I have come is the following code:
Sub Makro2()
Dim ws_3 As Worksheet
Set ws_3 = ThisWorkbook.Worksheets(2)
Application.CutCopyMode = False
ws_3.Range("E3:E400").FormulaR1C1 = "=RC[-2]-RC[-1]"
End Sub
So all I need in reality is for E3:E400 to be dynamic since the range of the other two columns change every day.
PS. Rather new at VBA.
This is just basic, ensure you declare your variable.
Dim lRow As Long
lRow = Range("D" & Rows.Count).End(xlUp).Row
Range("E3:E" & lRow).FormulaR1C1 =
You could try:
Option Explicit
Sub test()
Dim wsSource As Worksheet, wsDestination As Worksheet
Dim LastRow1 As Long, LastRow2 As Long, rng1 As Range, rng2 As Range, LastColumn As Long
With ThisWorkbook
Set wsSource = .Worksheets("Sheet1") '<- Data appears here
Set wsDestination = .Worksheets("Sheet2") '<- Data will be copy here
End With
With wsSource
'Let's say the two columns we want to copy is column A & B. Find Last row of A & B
LastRow1 = .Cells(.Rows.Count, "A").End(xlUp).Row
LastRow2 = .Cells(.Rows.Count, "B").End(xlUp).Row
'Create the ranges you want to copy
Set rng1 = .Range("A1:A" & LastRow1)
Set rng2 = .Range("B1:B" & LastRow2)
End With
With wsDestination
'Paste column after the last column of row 1. Find last column row 1
LastColumn = .Cells(1, .Columns.Count).End(xlToLeft).Column
rng1.Copy
.Cells(1, LastColumn + 1).PasteSpecial xlPasteValues
rng2.Copy
.Cells(1, LastColumn + 2).PasteSpecial xlPasteValues
End With
Application.CutCopyMode = False
End Sub
Hy Experts, I have two worksheets. I am trying to copy the data from sheet "Input Sheet" to "Database" sheet by using this code.
Sub CopyInvoiceNo()
Dim ws As Worksheet, ws1 As Worksheet
Dim lastrow As Long
Set ws = Sheets("Input Sheet")
Set ws1 = Sheets("Database")
lastrow = ws.Cells(Rows.Count, 4).End(xlUp).Row
ws.Range("A3:J" & lastrow).Copy
ws1.Range("B3").PasteSpecial xlPasteValues
ws1.Activate
End Sub
this code is working very fine. But there is a problem. It overwrites the data when I press the button 2nd time.
The goal is that every time when I press "Paste Button" it should paste data after the first filled row. I tried but in vain. HOw could it be done. Thanks in advance..
You aren't adjusting the target of the paste operation.
Sub CopyInvoiceNo()
Dim ws As Worksheet, ws1 As Worksheet
Dim lastrow As Long
Set ws = Sheets("Input Sheet")
Set ws1 = Sheets("Database")
lastrow = ws.Cells(Rows.Count, 4).End(xlUp).Row
ws.Range("A3:J" & lastrow).Copy
ws1.Range("B" & rows.count).end(xlup).offset(1, 0).PasteSpecial xlPasteValues
ws1.Activate
End Sub
I am currently trying to filter data and paste it into another sheet to a certain range but it is only posting the latest data row. How do I fix the code so that it selects all the rows with the code word and pastes it into the other sheet.
This is my code:
Private Sub CommandButton1_Click()
Dim lastrow As Long, i As Long
lastrow = Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To lastrow
If Sheets("sheet1").Cells(i, 1) = "pp" Then
Sheets("sheet1").Range(Cells(i, 2), Cells(i, 5)).Copy
ActiveSheet.Paste Destination:=Worksheets("Sheet5").Range("A11:A22")
End If
Next
End Sub
I think this is what you want.
Private Sub CommandButton1_Click()
Dim ws1 as Worksheet: Set ws1 = Thisworkbook.Sheets("Sheet1")
Dim ws2 as Worksheet: Set ws2 = Thisworkbook.Sheets("Sheet5")
Dim LRow1 As Long, LRow2 as Long, i As Long
LRow1 = ws1.Range("A" & ws1.Rows.Count).End(xlUp).Row
LRow2 = ws2.Range("A" & ws2.Rows.Count).End(xlUp).Row
For i = 2 To lastrow
If ws1.Cells(i, 1) = "pp" Then
ws1.Range(Cells(i, 1), Cells(i, 5)).Copy
ws2.Range("A" & LRow + 1).PasteSpecial xlPasteValues
End If
Next
End Sub
Here is a more effecient method using a For Each loop and one instance of Copy/Paste instead of 1 iteration for every matched cell.
Option Explicit
Sub Copy()
Dim ws1 As Worksheet: Set ws1 = ThisWorkbook.Sheets("Sheet1")
Dim ws2 As Worksheet: Set ws2 = ThisWorkbook.Sheets("Sheet2")
Dim TargetRange As Range, TargetCell As Range, CopyRange As Range
Set TargetRange = ws1.Range("A2:A" & ws.Range("A" & ws.Rows.Count).End(xlUp).Row)
For Each TargetCell In TargetRange
If TargetCell = "pp" Then
If CopyRange Is Nothing Then
Set CopyRange = TargetCell.Resize(1, 4)
Else
Set CopyRange = Union(CopyRange, TargetCell.Resize(1, 4))
End If
End If
Next TargetCell
CopyRange.Copy
ws2.Range("A" & ws2.Range("A" & ws2.Rows.Count).End(xlUp).Row).PasteSpecial xlPasteValuesAndNumberFormats
End Sub
Another method would be to apply a filter for your target value pp and then copy/paste visible cells.
I have a problem with the following vba script.
I want to copy some cells from one sheet to another.
The first sheet is selected based its name. The sheet where i want to paste the cells is selected based on cell B1 in the first sheet.
I am using the following code:
Dim ws as Worksheet
Dim LR3 as Long
Dim LR4 as Long
Dim LR5 as Long
Dim ws3 as Worksheet
For Each ws In ActiveWorkbook.Worksheets
If Not ws.Name Like "BC-*" Then
LR3 = ws.Cells(Rows.Count, 1).End(xlUp).Row
ws.Range("E" & LR3 + 1).Formula = "=SUM(E4:E" & LR3 & ")"
Dim i As Long, n As Long
n = ws.Cells(Rows.Count, 1).End(xlUp).Row
With ws.Range("S1")
.Formula = "=myJoin(A4:A" & n & ","""")"
.Value = .Value
End With
LR4 = ws.Cells(Rows.Count, 6).End(xlUp).Row
ws.Range("F4:F" & LR4).Copy
ws.Range("M4:M" & LR4).PasteSpecial Paste:=xlPasteValues
ws.Range("M4:M" & LR4).RemoveDuplicates Columns:=1, Header:=xlNo
LR5 = ws.Cells(Rows.Count, 13).End(xlUp).Row
ws.Range("M4:M" & LR4).Cut
Set ws3 = ws.Range("B1").Value
ws3.Range("A30").PasteSpecial xlPasteValues
You need to use:
Set ws3 = ActiveWorkbook.Worksheets(ws.Range("B1").Value)
for example. Adjust the workbook if required.