Im trying to copy ranges from my WeeklyDiet sheet to my DietStats sheet.
In cell A1 of WeeklyDiet I enter the number of the week as follows e.g Wk1,Wk2 etc.
I want to paste the data for the week in A1 to whatever row in DietStats.Range(B4:B55) that contains its equivalent weeknumber e.g If Wk2 is in A1 I want the data to be pasted in whatever row contains Wk2 in Range(B4:B55) of the DietStats sheet.
Im getting an Object Variable or With Block variable not set error message.
Sub SaveDietMacrosForWeek()
Dim Ws1 As Worksheet
Dim Ws2 As Worksheet
Dim NR As Long
Set Ws1 = ActiveWorkbook.Sheets("WeeklyDiet")
Set Ws2 = ActiveWorkbook.Sheets("DietStats")
Dim Week As String
Week = Ws1.Range("A1")
NR = Ws2.Range("B4:B55").Find(Week).Row
Ws1.Range("E75:I75").Copy
Ws2.Range("K" & NR).PasteSpecial (xlPasteValues)
Ws1.Range("L75:P75").Copy
Ws2.Range("R" & NR).PasteSpecial (xlPasteValues)
Ws1.Range("S75:W75").Copy
Ws2.Range("Y" & NR).PasteSpecial (xlPasteValues)
Ws1.Range("Z75:AD75").Copy
Ws2.Range("AF" & NR).PasteSpecial (xlPasteValues)
Ws1.Range("AG75:AK75").Copy
Ws2.Range("AM" & NR).PasteSpecial (xlPasteValues)
Ws1.Range("AN75:AR75").Copy
Ws2.Range("AT" & NR).PasteSpecial (xlPasteValues)
Ws1.Range("AU75:AY75").Copy
Ws2.Range("BA" & NR).PasteSpecial (xlPasteValues)
ActiveWorkbook.Save
End Sub
Use Applicatiopn.Match on the whole of column B to get the row number. By passing the return to a variant you will either get the true row number or an error value.
Sub SaveDietMacrosForWeek()
Dim Ws1 As Worksheet
Dim Ws2 As Worksheet
Dim NR As Variant
Set Ws1 = ActiveWorkbook.Sheets("WeeklyDiet")
Set Ws2 = ActiveWorkbook.Sheets("DietStats")
Dim Week As String
Week = Ws1.Range("A1")
NR = Application.Match(Week, Ws2.Range("B:B"), 0)
If Not IsError(NR) Then
Ws2.Range("K" & NR).Resize(1, 5) = Ws1.Range("E75:I75").Value
Ws2.Range("R" & NR).Resize(1, 5) = Ws1.Range("L75:P75").Value
Ws2.Range("Y" & NR).Resize(1, 5) = Ws1.Range("S75:W75").Value
Ws2.Range("AF" & NR).Resize(1, 5) = Ws1.Range("Z75:AD75").Value
Ws2.Range("AM" & NR).Resize(1, 5) = Ws1.Range("AG75:AK75").Value
Ws2.Range("AT" & NR).Resize(1, 5) = Ws1.Range("AN75:AR75").Value
Ws2.Range("BA" & NR).Resize(1, 5) = Ws1.Range("AU75:AY75").Value
End If
ActiveWorkbook.Save
End Sub
I've used direct value transfer instead of your Copy, Paste Special, Values. Direct value transfer is more efficient but requires a target that is the same size as the source.
Not sure what Week is so may need some adjusting.
Sub SaveDietMacrosForWeek()
Dim Ws1 As Worksheet
Dim Ws2 As Worksheet
Dim r As Range
Dim NR As Long
Dim Week As String
Set Ws1 = ActiveWorkbook.Sheets("WeeklyDiet")
Set Ws2 = ActiveWorkbook.Sheets("DietStats")
Week = Ws1.Range("A1")
Set r = Ws2.Range("B4:B55").Find(What:=Week, LookAt:=xlWhole, MatchCase:=False, SearchFormat:=False)
If Not r Is Nothing Then
NR = r.Row
'rest of code
End If
End Sub
Related
New VBA user here, the below code matches the 1st column in a worksheet with the 1st column in another worksheet using vlookup then copies the first cell from 1st to 2nd as the screenshots.
Code
Sub solution()
Dim oldRow As Integer
Dim newRow As Integer
Dim lrow_output As Integer 'variable indicating last fulfilled row
Dim WB_Input As Workbook
Dim WB_Output As Workbook
Dim WS_Input As Worksheet
Dim WS_Output As Worksheet
Dim funcStr As String
Set WB_Input = Workbooks("input")
Set WB_Output = Workbooks("output1")
Set WS_Input = WB_Input.Worksheets("input")
Set WS_Output = WB_Output.Worksheets("Sheet1")
With WS_Output
lrow_output = .Cells(.Rows.Count, 1).End(xlUp).Row
End With
With WS_Input
funcStr = "=IFERROR(VLOOKUP(" & Cells(1, 1).Address(False, False) & "," & "'[" & WB_Input.Name & "]" & .Name & "'!" & Range(.Columns(1), .Columns(2)).Address & ",2,0),"""")"
End With
With WS_Output
.Cells(1, 2).Formula = funcStr
.Cells(1, 2).Copy
Range(.Cells(1, 2), .Cells(lrow_output, 2)).PasteSpecial xlPasteFormulas
WS_Output.Calculate
Range(.Cells(1, 2), .Cells(lrow_output, 2)).Copy
Range(.Cells(1, 2), .Cells(lrow_output, 2)).PasteSpecial xlPasteValues
Application.CutCopyMode = False
End With
End Sub
Problem: I need the code to copy and paste the all data in the row, not just the first cell.
Problem2:If possible I need the code to scan multiple sheets, not just one so it would be 1 input main workbook sheet and 4 output sheets in the output workbook.
Problem3(Optional): if possible I need the successfully matched and copied rows in the input workbook to be colored to tell them from the unsuccessful matches.
Thank you in advance, I really appreciate all the possible aid.
Here is a quick macro that will take the active cell row copy it and then select specified sheet and paste it in active cell row:
Sub CopyPaste()
'
' CopyPaste Macro
'
'
ActiveCell.Rows("1:1").EntireRow.Select
Selection.Copy
Sheets("Sheet#").Select
ActiveCell.Rows("1:1").EntireRow.Select
ActiveSheet.Paste
End Sub
I am trying to upload the data to the destination workbook from the source workbook.
Let's assume I have 15-20 rows of data.
There are two conditions:
When the frmData.txtdate.Value (textbox value from the userform) is = to the destination workbook's cell value, then there will be a MsgBox displaying that the data is already copied. Also I want that if this gets executed then the destination workbook should get closed.
When the frmData.txtdate.Value (textbox value from the userform) is = to the source workbook's cell value , then the whole data from range A2:T999 would get copied and pasted to the destination workbooks range A:Lastrow
But when I try doing it, all the 15-20 rows get duplicated and copied for 15-20 times below each other.
The code is as follows:
Private Sub Upload()
Dim SourceWB As Workbook
Dim SourceWs As Worksheet
Dim DesWB As Workbook
Dim DesWs As Worksheet
Dim DateRange As Range
Dim DesDataRange As Range
Dim LastRowCount As Long 'Upload Button Value
Dim DesLastRow As Long
Dim Ls As Long
Dim Y As Long
Set SourceWB = ThisWorkbook
Set SourceWs = SourceWB.Worksheets("Database")
Set DesWB = ActiveWorkbook
Set DesWs = DesWB.ActiveSheet
LastRowCount = SourceWs.Range("D" & Rows.count).End(xlUp).Row
DesLastRow = DesWs.Range("D" & Rows.count).End(xlUp).Row
Set DateRange = SourceWs.Range("D2", "D" & LastRowCount)
Set DesDateRange = DesWs.Range("D2", "D" & DesLastRow)
'Check Destination File for Similar Date
For Each Cell In DesDateRange
If Cell.Value = frmData.txtdate.Value Then
MsgBox "Data Already Colated, If you want To make any Changes Contact your SME Or Admin"
Exit Sub
End If
Next Cell
'Paste Similar Date Values to destination file
'*The problem starts here*
For Each Cell In DateRange
If Cell.Value = frmData.txtdate.Value Then
'Y = Cell.Row 'Cells(y, 1), Cells(y, 20)
SourceWs.Range("A" & 2, "T" & LastRowCount).Copy
Workbooks(FileNameValue).Activate
Ls = ActiveWorkbook.Worksheets("Sheet1").Range("A" & Rows.count).End(xlUp).Row
ActiveWorkbook.Worksheets("Sheet1").Range("A" & Ls + 1).PasteSpecial Paste:=xlPasteValues 'AndNumberFormats
End If
Next
ActiveWorkbook.Save
ActiveWorkbook.Close
End Sub
In that last for-loop you are:
Going through each cell in a column of SourceWS
For Each Cell In DateRange
Each time copying the whole Source Range
If Cell.Value = frmData.txtdate.Value Then
SourceWs.Range("A" & 2, "T" & LastRowCount).Copy
Workbooks(FileNameValue).Activate
Ls = ActiveWorkbook.Worksheets("Sheet1").Range("A" & Rows.count).End(xlUp).Row
ActiveWorkbook.Worksheets("Sheet1").Range("A" & Ls + 1).PasteSpecial Paste:=xlPasteValues 'AndNumberFormats
End If
Therefore, if more than one cell in DateRange equal the value in txtdate, the whole SourceRange will be copyied (that many times).
So the result you are describing is exactly what is coded.
Now if you want to copy the range only once you have two options:
a) Easiest with the code you have: add an Exit For within right after pasting the range.
b) Best Practice: instead of the For each Cell in DateRange loop, do something like:
Dim rn_found
Set rn_found = DateRange.find(frmData.txtdate.Value)
If Not rn_found Is Nothing Then
'... do your thing
End If
I have a data set with columns from A to AZ. I want to find if any cell value in Columns A & B is found in Columns AA:AZ and I want a list of those unique not found values from all the compared columns.
What I did first is create 2 new sheets to separate the comparison. 1st sheet (SKUReference) which is copied from column A & B. Second sheet is (SKUNewList) which is copied from AA till AZ. I created a 3rd sheet (NotFoundSKU) to have the desired output which is the Not Found values from the comparison.
The data in the 1st sheet (SKUReference) looks like below :
The data in the 2nd sheet (SKUNewList) looks like below :
The issue I'm facing is : 1- the code isn't finding the Mismatches. 2- It's not storing the unique mismatches correctly. 3- It's not generating those mismatches in the 3rd sheet (NotFoundSKU).
Sub yg23iwyg()
Dim wst As Worksheet
Dim wet As Worksheet
Set wst = Worksheets.Add
Set wet = Worksheets.Add
Set wrt = Worksheets.Add
wst.Name = "SKUReference"
wet.Name = "SKUNewList"
wrt.Name = "NotFoundSKU"
With Worksheets("Sheet1")
.Range(.Cells(1, "A"), .Cells(.Rows.Count, "B").End(xlUp)).Copy _
Destination:=wst.Cells(1, "A")
.Range(.Cells(1, "AA"), .Cells(.Rows.Count, "AZ").End(xlUp)).Copy _
Destination:=wet.Cells(1, "A")
'alternate with Union'ed range - becomes a Copy, Paste Special, Values and Formats because of the union
.Range("AA:AZ").Copy _
Destination:=wet.Cells(1, "A")
End With
Dim wksMaster As Worksheet, wksSearch As Worksheet
Dim rngMaster As Range, rngSearch As Range
Set wksMaster = Sheets("SKUReference")
Set wksSearch = Sheets("SKUNewList")
With wksMaster
Set rngMaster = .Range("A1:B100" & .Range("A1").SpecialCells(xlCellTypeLastCell).Row)
End With
With wksSearch
Set rngSearch = .Range("A1:Y100" & .Range("A1").SpecialCells(xlCellTypeLastCell).Row)
End With
With rngMaster
For Each cll In rngSearch
Set c = .Find(cll.Value2, LookIn:=xlValues)
If c Is Nothing Then
'MsgBox cll.Value2 & " not found in the SKU Reference List."
Sheets("NotFoundSKU").Range("A1") = cll.Value2
End If
Next
End With
End Sub
Try this, which incorporates comments above (to set rngMaster and rngSearch) and will list values not found in a list going down by finding the first empty cell.
Sub yg23iwyg()
Dim wst As Worksheet
Dim wet As Worksheet, c as range, cll as range
Set wst = Worksheets.Add
Set wet = Worksheets.Add
Set wrt = Worksheets.Add
wst.Name = "SKUReference"
wet.Name = "SKUNewList"
wrt.Name = "NotFoundSKU"
With Worksheets("Sheet1")
.Range(.Cells(1, "A"), .Cells(.Rows.Count, "B").End(xlUp)).Copy _
Destination:=wst.Cells(1, "A")
.Range(.Cells(1, "AA"), .Cells(.Rows.Count, "AZ").End(xlUp)).Copy _
Destination:=wet.Cells(1, "A")
'alternate with Union'ed range - becomes a Copy, Paste Special, Values and Formats because of the union
.Range("AA:AZ").Copy _
Destination:=wet.Cells(1, "A")
End With
Dim wksMaster As Worksheet, wksSearch As Worksheet
Dim rngMaster As Range, rngSearch As Range
Set wksMaster = Sheets("SKUReference")
Set wksSearch = Sheets("SKUNewList")
With wksMaster
Set rngMaster = .Range("A1:B" & .Range("B" & .Rows.Count).End(xlUp).Row)
End With
With wksSearch
Set rngSearch = .Range("A1:Y" & .Range("Y" & .Rows.Count).End(xlUp).Row)
End With
With rngMaster
For Each cll In rngSearch
Set c = .Find(cll.Value2, LookIn:=xlValues) 'i would consider adding more parameters here
If c Is Nothing Then
Sheets("NotFoundSKU").Range("A" & Rows.Count).End(xlUp)(2).Value = cll.Value2
End If
Next
End With
End Sub
I have a file (called original) that has partially information for each row. Each row has a file name column (from where information is to be captured from).
For each row I'd like to open up the file in the file name column, and grab information from certain rows.
In the file it is only one column, with rows "Supplier Number : _____", the location of this row is variable, so I'd like to iterate through each row in the file to copy this cell value and paste it into the original file in the corresponding row.
This is what I have so far:
Const FOLDER_PATH = "C:\Users\[user]\Downloads\"
Sub iterateThroughAll()
ScreenUpdating = False
Dim wks As Worksheet
Set wks = ActiveSheet
Dim source As String
Dim target As String
Dim update As String
Dim rowT As Integer
rowT = 2
rowTT = 1
Dim rowRange As Range
Dim colRange As Range
Dim rowRangeT As Range
Dim LastCol As Long
Dim LastRow As Long
Dim LastRowT As Long
LastRow = wks.Cells(wks.Rows.Count, "A").End(xlUp).Row
Set rowRange = wks.Range("A2:A" & LastRow)
'Loop through each row
For Each rrow In rowRange
source = FOLDER_PATH & wks.Cells(i, 18).Value 'the name of the file we want to grab info from in this Column, always populated
'if the cell is empty, search through the file for "Supplier Number : "
If IsEmpty(wks.Cells(rowT, 19)) Then
Set wb = Workbooks.Open(source)
wb.Activate
LastRowT = Cells.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row
Set rowRangeT = wks.Range("A1:A" & LastRowT)
For Each i In rowRangeT
If InStr(i.Cells.Offset(rowTT), "Supplier") > 0 Then
Range("A" & rowTT).Select
Selection.Copy
Windows("Get Supplier Number.xlsm").Activate
Range("A" & rowT).Select
wks.Paste
Else
rowTT = rowTT + 1
End If
Next i
wb.Close
Next rrow
ScreenUpdating = True
End Sub
I get the pastespecial error 1004.
What is expected is that for each row in "Get Supplier Number.xlsm", the row's A column is updated with the information
Thank you for helping!
First of all you should get rid of Activate and Select methods. You don't have to use them and they give nothing to your code. Using them is not a good approach.
To avoid them you should use specific references. Which you are doing so, until a specific point. Inside the for loop, after setting the wb, replace everything with the following:
With wb.Worksheets(1)
LastRowT = .Cells.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row
Set rowRangeT = .Range("A1:A" & LastRowT)
For Each i In rowRangeT
If InStr(i.Cells.Offset(rowTT), "Supplier") > 0 Then
.Range("A" & rowTT).Copy wks.Range("A" & rowT)
Else
rowTT = rowTT + 1
End If
Next i
wb.Close
End With
I think this should do the job for you.
PS: If you need just the value of the cell in the opened workbook, then you could replace the Copy line with a simple equality:
wks.Range("A" & rowT) = .Range("A" & rowTT)
I have code to archive data from "sheet1" to "sheet2". It overwrites existing data in the "sheet2" rows from the previous archive exercise.
How do I have it seek the next blank row vs. overwriting existing data?
I have two header rows so it should commence with row 3.
Option Explicit
Sub Archive()
Dim lr As Long, I As Long, rowsArchived As Long
Dim unionRange As Range
Sheets("sheet1").Unprotect Password:="xxxxxx"
Application.ScreenUpdating = False
With Sheets("sheet1")
lr = .Range("A" & .Rows.Count).End(xlUp).Row
For I = 3 To lr 'sheets all have headers that are 2 rows
If .Range("AB" & I) = "No" Then
If (unionRange Is Nothing) Then
Set unionRange = .Range(I & ":" & I)
Else
Set unionRange = Union(unionRange, .Range(I & ":" & I))
End If
End If
Next I
End With
rowsArchived = 0
If (Not (unionRange Is Nothing)) Then
For I = 1 To unionRange.Areas.Count
rowsArchived = rowsArchived + unionRange.Areas(I).Rows.Count
Next I
unionRange.Copy Destination:=Sheets("sheet2").Range("A3")
unionRange.EntireRow.Delete
End If
Sheets("sheet2").Protect Password:="xxxxxx"
Application.CutCopyMode = False
Application.ScreenUpdating = True
MsgBox "Operation Completed. Total Rows Archived: " & rowsArchived
End Sub
Change
unionRange.Copy Destination:=Sheets("sheet2").Range("A3")
... to,
with worksheets("sheet2")
unionRange.Copy _
Destination:=.Cells(.rows.count, 1).end(xlup).offset(1, 0)
end with
This is like starting at the bottom row of the worksheet (e.g. A1048576) and tapping [ctrl+[↑] then selecting the cell directly below it.
The With ... End With statement isn't absolutely necessary but it shortens the code line enough to see it all without scolling across. unionRange has been definied by parent worksheet and cell range so there is no ambiguity here.
I'd propose the following "refactoring"
Option Explicit
Sub Archive()
Dim sht1 As Worksheet, sht2 As Worksheet
Set sht1 = Sheets("sheet1")
Set sht2 = Sheets("sheet2")
sht1.Unprotect Password:="xxxxxx"
With sht1.Columns("AB").SpecialCells(xlCellTypeConstants).Offset(, 1) '<== change the offset as per your need to point to whatever free column you may have
.FormulaR1C1 = "=if(RC[-1]=""NO"","""",1)"
.Value = .Value
With .SpecialCells(xlCellTypeBlanks)
.EntireRow.Copy Destination:=sht2.Cells(sht2.Rows.Count, 1).End(xlUp).Offset(1, 0)
MsgBox "Operation Completed. Total Rows Archived: " & .Cells.Count
End With
.ClearContents
End With
sht2.Protect Password:="xxxxxx"
End Sub
just choose a "free" column in "Sheet1" to be used as a helper one and that'll be cleared before exiting macro. In the above code I assumed it's one column to the right of "AB"
The following approach worked for me! I'm using a button to trigger macro.
Every time it takes the last row and append it to new sheet like a history. Actually you can make a loop for every value inside your sheet.
Sub copyProcess()
Application.ScreenUpdating = False
Dim copySheet As Worksheet
Dim pasteSheet As Worksheet
Dim source_last_row As Long 'last master sheet row
source_last_row = 0
source_last_row = Range("A:A").SpecialCells(xlCellTypeLastCell).Row
Set copySheet = Worksheets("master")
Set pasteSheet = Worksheets("alpha")
copySheet.Range("A" & source_last_row, "C" & source_last_row).copy
pasteSheet.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial
xlPasteValues
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub