I am currently trying to make a macro to pull all of the data from a specific row on my sales quote template workbook and then make it paste into the next available row on my quote logger workbook but im really struggling to find the right code to make it work. ive searched around but found nothing concrete that I could use.
what I have so far is below.
Option Explicit
Sub Test()
Dim sht1 As Worksheet, sht2 As Worksheet
Dim i As Long
Set sht1 = ThisWorkbook.Worksheets("Sheet1")
Set sht2 = "..............RAYOTEC LOGGER.xlsm"
For i = 2 To sht1.Cells(sht1.Rows.Count, "M").End(xlUp).Row
If sht1.Range("M" & i).Value = "No" Then
sht1.Range("A" & i).EntireRow.Cut sht2.Range("A" & sht2.Cells(sht2.Rows.Count, "M").End(xlUp).Row + 1)
End If
Next i
End Sub
Thanks in advance for any help
Change the part of your code before FOR loop with this,
Dim sht1 As Worksheet
Dim sht2 As Worksheet
Dim wb As Workbook
Dim i As Long
Set sht1 = ThisWorkbook.Worksheets("Sheet1")
Set wb = Application.Workbooks.Open("..............RAYOTEC LOGGER.xlsm")
Set sht2 = wb.Sheets("Sheet1")
Also you can use the below for the rest of the code as it just takes the values easily and deletes the row data that you do not need.
Dim sht1 As Worksheet
Dim sht2 As Worksheet
Dim i, n As Long
Dim iMx, nMx As Long
iMx = sht1.Cells(sht1.Rows.Count, "M").End(xlUp).Row
For i = 2 To iMx
nMx = sht2.Cells(sht2.Rows.Count, "A").End(xlUp).Row
If sht1.Range("M" & i).Value = "No" Then
sht2.Range("A" & nMx + 1).EntireRow.Value = sht1.Range("A" & i).EntireRow.Value
sht1.Range("A" & i).EntireRow.Delete Shift:=xlUp
i = i - 1
End If
Next i
Related
So I'm trying to copy different columns up to the last row used and just loop through every range I'm trying to access. For this I declared an array that stores the first half of the range (fixed) and add the last row with & LastRow within the Range() but I always get an error Run-time error 9 Subscript out of range when looping through these ranges (the first row of the loop is marked). I just don't get why this isn't working (storing the & LastRow in the array doesn't work either). I need this LastRow to be variable since it's going to change in the later section of the macro.
Sub ImportRows()
Dim wbk As Workbook
Dim LastRow As Long
Dim CopiedColumns As Variant
Dim InsertColumns As Variant
Dim i As Integer
Set wbk = ActiveWorkbook
CopiedColumns = Array("A2:A", "C2:C", "F2:F", "J2:J", "L2:L")
'Copy Paste
'###########################################
InsertColumns = Array("A2:A", "B2:B", "C2:C", "D2:D", "E2:E")
With wbk.Worksheets("RawData")
LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
End With
For i = 1 To 5
wbk.Worksheets("RawData").Range(CopiedColumns(i) & LastRow).Copy
wbk.Worksheets("Comparrisson").Range(InsertColumns(i) & LastRow).Insert
Next i
End Sub
Thanks for literally any help!
As I said in my comments, your code should work if the iteration is adapted to 1D arrays type. Please, test the next code, using only arrays and not involving the clipboard, slowing Excel and consuming more resources:
Sub ImportColumns()
Dim wbk As Workbook, LastRow As Long, CopiedColumns, InsertColumns As Variant
Dim sh As Worksheet, sh1 As Worksheet, i As Long, arrC
Set wbk = ActiveWorkbook
CopiedColumns = Array("A2:A", "C2:C") ', "F2:F", "J2:J", "L2:L")
Set sh = wbk.Worksheets("RawData")
Set sh1 = wbk.Worksheets("Comparrisson")
'Copy columns
'###########################################
InsertColumns = Array("A2", "B2", "C2", "D2", "E2")
LastRow = sh.cells(sh.rows.count, 1).End(xlUp).row
For i = 0 To 1
arrC = sh.Range(CopiedColumns(i) & LastRow)
sh1.Range(InsertColumns(i)).Resize(UBound(arrC), 1).value = arrC
Next i
End Sub
And a more compact solution, not involving any iteration:
Sub ImportColumnsArr()
Dim wbk As Workbook, LastRow As Long, arr, arrC
Dim sh As Worksheet, sh1 As Worksheet
Set wbk = ActiveWorkbook
Set sh = wbk.Worksheets("RawData")
Set sh1 = wbk.Worksheets("Comparrisson")
LastRow = sh.cells(sh.rows.count, 1).End(xlUp).row
arr = sh.Range("A2:L" & LastRow).value
arrC = Application.Index(arr, Evaluate("row(1:" & UBound(arr) & ")"), Array(1, 3, 5, 10, 12))
'Copy columns:
sh1.Range("A2").Resize(UBound(arrC), UBound(arrC, 2)).value = arrC
End Sub
First of all thanks for your help.
I've been trying to get a dynamic list that copies values from on excel to another depending on an "IF" condition, which has worked quite fine. But I can only do it for 1 condition instead of a Range of conditions.
In excel I would usually use the COUNTIF function to see if you can find a range of values inside another range, but i am quite new to VBA and I wouldn't know how how to express this in a loop for a Range.
Example below of what has worked with one condition:
As you can see I am using "Investor" as my condition, but I need it to be for a range of values.
Thanks for your help!
LastRows = Worksheets("Data").Cells(Rows.Count, 1).End(xlUp).Row + 1
For i = 2 To LastRows
If Worksheets("Data").Range("F" & i).Value = "Investor" Then
'Instead of "Investor" I want to do something that take a list of values. Eg : If If Worksheets("Data").Range("F" & i).Value = "Range("A1:A"&LastRows) Then
Worksheets("Data").Range("A" & i).Copy
Worksheets("Email Format").Activate
LastRowEmail = Worksheets("Email Format").Cells(Rows.Count, 1).End(xlUp).Row + 1
Worksheets("Email Format").Range("A" & LastRowEmail).Select
ActiveSheet.Paste
End If
Application.Match Vs WorksheetFunction.Match
You can use one of the following Match solutions.
Option Explicit
Sub MultiCriteria1()
Dim wb As Workbook: Set wb = ThisWorkbook
Dim wsD As Worksheet: Set wsD = wb.Worksheets("Data")
Dim wsE As Worksheet: Set wsE = wb.Worksheets("Email Format")
Dim LastRowD As Long: LastRowD = wsD.Cells(wsD.Rows.Count, 1).End(xlUp).Row
Dim CurrentE As Long: CurrentE = wsE.Cells(wsE.Rows.Count, 1).End(xlUp).Row
Dim i As Long
For i = 2 To LastRowD
If Not IsError(Application.Match(wsD.Range("F" & i).Value, _
wsD.Range("A1:A" & LastRowD), 0)) Then
CurrentE = CurrentE + 1
wsE.Range("A" & CurrentE).Value = wsD.Range("A" & i).Value
End If
Next i
End Sub
Sub MultiCriteria2()
Dim wb As Workbook: Set wb = ThisWorkbook
Dim wsD As Worksheet: Set wsD = wb.Worksheets("Data")
Dim wsE As Worksheet: Set wsE = wb.Worksheets("Email Format")
Dim LastRowD As Long: LastRowD = wsD.Cells(wsD.Rows.Count, 1).End(xlUp).Row
Dim CurrentE As Long: CurrentE = wsE.Cells(wsE.Rows.Count, 1).End(xlUp).Row
Dim CurrVal As Long
Dim i As Long
For i = 2 To LastRowD
On Error Resume Next
CurrVal = WorksheetFunction.Match(wsD.Range("F" & i).Value, _
wsD.Range("A1:A" & LastRowD), 0)
If Err.Number = 0 Then
CurrentE = CurrentE + 1
wsE.Range("A" & CurrentE).Value = wsD.Range("A" & i).Value
End If
On Error GoTo 0
Next i
End Sub
This is just an example but should steer you in right direction.
Dim rngYourRange as Range
Set rngYourRange = Range("A1:C10")
Dim rngEachRange as Range
For each rngEachRange in rngYourRange 'or rngYourRange.Rows or rngYourRange.Columns
if rngEachRange.value = 1 then 'or whatever
'do what you need
end if
next rngEachRange
I have problem to make a dynamic range to copy between two workbooks. I have create the following code and when I run step by step the code I take “Run time error 1004” “Method Range of object worksheet failed” My thought is to create dynamic range for the workbook with new data because is change all the time and the only last cell with data is in column “D” then expand this to column “S” and copy this to Master workbook Data sheet and again find the last used cell in column D and offset this to column “A” . How can make this task?
Sub CopyValuesToMaster()
Dim wsCopy As Worksheet
Dim wsDest As Worksheet
Dim RngAC1 As Range
Dim RngAC2 As Range
Dim NewRng As Range
Dim DestLastRow As Long
Set wsCopy = Workbooks("sl0032019.xls").Worksheets("Sheet1")
Set wsDest = Workbooks("Master-Braun.xlsx").Worksheets("Data")
DestLastRow = Cells(Rows.Count, "D").End(xlUp).Offset(1, -3).Row
CopyLastRow = wsCopy.Cells(wsCopy.Rows.Count, "D").End(xlUp).Row
Set RngAC1 = wsCopy.Range("A1")
Set RngAC2 = wsCopy.Range(Cells(Rows.Count, "D").End(xlUp).Offset(0, 15).Row)
Set NewRng = Range(RngAC1.Address & ":" & RngAC2.Address)
NewRng.Copy wsDest.Range("A" & DestLastRow)
End Sub
Try this.
Sub CopyValuesToMaster()
Dim wsCopy As Worksheet
Dim wsDest As Worksheet
Dim RngAC1 As Range
Dim RngAC2 As Range
Dim NewRng As Range
Dim DestLastRow As Long
Set wsCopy = Workbooks("sl0032019.xls").Worksheets("Sheet1")
Set wsDest = Workbooks("Master-Braun.xlsx").Worksheets("Data")
DestLastRow = wsDest.Cells(Rows.Count, "D").End(xlUp).Offset(1, -3).Row
CopyLastRow = wsCopy.Cells(wsCopy.Rows.Count, "D").End(xlUp).Row
With wsCopy
Set RngAC1 = .Range("A1")
Set RngAC2 = .Range("S" & .Cells(.Rows.Count, "D").End(xlUp).Row)
End With
Range(RngAC1, RngAC2).Copy wsDest.Range("A" & DestLastRow)
End Sub
I'm trying to write VBA code to cut/copy paste rows in one worksheet to a new worksheet as long as column H contains any of the values I dictate.
The current code I have works when I only set one value, but I would like the code to execute as long as any of the values I dictate are in the cell. Please advise, thanks.
Sub CutPastebyAM()
Dim sht1 As Worksheet, sht2 As Worksheet
Dim i As Long
Set sht1 = ThisWorkbook.Worksheets("Data")
Set sht2 = ThisWorkbook.Worksheets("Sheet1")
For i = 2 To sht1.Cells(sht1.Rows.Count, "H").End(xlUp).Row
If sht1.Range("H" & i).Value = "Laine Sikula" Or "Kim Gotti" Then
sht1.Range("A" & i).EntireRow.Cut sht2.Range("A" & sht2.Cells(sht2.Rows.Count, "H").End(xlUp).Row + 1)
End If
Next i
End Sub
Almost there:
EDIT - copying to different sheets
Sub CutPastebyAM()
Dim sht1 As Worksheet
Dim i As Long, v, SheetName
Set sht1 = ThisWorkbook.Worksheets("Data")
For i = 2 To sht1.Cells(sht1.Rows.Count, "H").End(xlUp).Row
Select Case sht1.Range("H" & i).Value
Case "Laine Sikula": SheetName = "Sheet1"
Case "Kim Gotti": SheetName = "Sheet2"
Case Else: SheetName = ""
End Select
If Len(SheetName) > 0 Then
With Sheets(SheetName)
sht1.Range("A" & i).EntireRow.Cut _
.Range("A" & .Cells(.Rows.Count, "H").End(xlUp).Row + 1)
End With
End If
Next i
End Sub
I have this code, by a responder who helped me to define my needs yesterday - but there somethings i want to change, but my vba skills are very low and dont know how and where to modify the code. I want it do 2 Things.
Right know it transferes data, i want it to copy it, over with the values that are calculated in the cells. I have some cells, where i have some formulas and it dosent follows with it. I just want the calculated value over. I dont know if i can use xlPasteValues somewhere to get what i want?
The second thing that i want is, when copying over, i want to be on top and the previous copies move Down, so the latest copy always are in the top.
Thank you before handed :)
Option Explicit
Sub Copypastemeddata()
Dim wb As Workbook
Dim ws As Worksheet
Dim sourceCell As Range
Dim targetSheet As Worksheet
Set wb = ThisWorkbook
Set ws = wb.Worksheets("Opgørsel")
Set sourceCell = ws.Range("D3") 'Cell with sheet names for copying to
With ws
Set targetSheet = wb.Worksheets(sourceCell.Text)
Dim nextRow As Long
nextRow = GetLastRow(targetSheet, 1)
nextRow = IIf(nextRow = 1, 1, nextRow + 1)
.Range("A1").CurrentRegion.Copy targetSheet.Range("A" & nextRow)
targetSheet.Columns.AutoFit
End With
End Sub
Public Function GetLastRow(ByVal ws As Worksheet, Optional ByVal columnNumber As Long = 1) As Long
With ws
GetLastRow = .Cells(.Rows.Count, columnNumber).End(xlUp).Row
End With
End Function
Please give this a try...
The StartRow variable defines the destination row on targetSheet, you may change it as per your requirement.
Sub Copypastemeddata()
Dim wb As Workbook
Dim ws As Worksheet
Dim sourceCell As Range
Dim targetSheet As Worksheet
Dim StartRow As Integer
Application.ScreenUpdating = False
Set wb = ThisWorkbook
Set ws = wb.Worksheets("Opgørsel")
Set sourceCell = ws.Range("D3") 'Cell with sheet names for copying to
StartRow = 1 'Destination row on targetSheet
With ws
Set targetSheet = wb.Worksheets(sourceCell.Text)
.Range("A1").CurrentRegion.Copy
targetSheet.Range("A" & StartRow).Insert shift:=xlDown
targetSheet.Range("A" & StartRow).PasteSpecial xlPasteValues
targetSheet.Columns.AutoFit
End With
Application.CutCopyMode = 0
Application.ScreenUpdating = True
End Sub
substitute
Dim nextRow As Long
nextRow = GetLastRow(targetSheet, 1)
nextRow = IIf(nextRow = 1, 1, nextRow + 1)
.Range("A1").CurrentRegion.Copy targetSheet.Range("A" & nextRow)
with
With .Range("A1").CurrentRegion
targetSheet.Rows(1).Resize(.Rows.Count).Insert shift:=xlUp
targetSheet.Range("A1").Resize(.Rows.Count, .Columns.Count).Value = .Value
End With