I need to fill down a value in Sheet 1 Cell A2 with =Sheet 2 Cell A2 until the linked value is blank. I dont really know what to do.
I got so far so that I only need zeros in the fields:
Sub Test1()
Dim x As Integer
Dim i As Integer
Dim wsh As Worksheet
Set wsh = Worksheets("List with Weights")
Application.ScreenUpdating = False
i = 2
While (wsh.Cells(i, 1)) <> ""
wsh.Cells(i, 1).FormulaR1C1 = "='Sample Weight'!RC[0]"
wsh.Cells(i, 2).FormulaR1C1 = "='Sample Weight'!RC[0]"
wsh.Cells(i, 3).FormulaR1C1 = "='IS Weight'!RC[-1]"
i = i + 1
Wend
' Selects cell down 1 row from active cell.
ActiveCell.Offset(1, 0).Select
Columns("A:C").Select
Columns("A:C").EntireColumn.AutoFit
Application.ScreenUpdating = True
Range("A1").Select
End Sub
If I have understood you correctly, there is no need for a loop. Is this what you are trying?
Option Explicit
Sub Sample()
Dim wsThis As Worksheet
Dim wsThat As Worksheet
Dim wsOther As Worksheet
'~~> Set your relevant worksheets
Set wsThis = ThisWorkbook.Sheets("List with Weights")
Set wsThat = ThisWorkbook.Sheets("Sample Weight")
Set wsOther = ThisWorkbook.Sheets("IS Weight")
'~~> Find the last row in Col A of Sample Weight worksheet
Dim wsThatLRow As Long
wsThatLRow = wsThat.Range("A" & wsThat.Rows.Count).End(xlUp).Row
'~~> Insert the formula in 1 go in the relevant range
With wsThis
.Range("A2:A" & wsThatLRow).Formula = "='" & wsThat.Name & "'!A2"
.Range("B2:B" & wsThatLRow).Formula = "='" & wsThat.Name & "'!B2"
.Range("C2:C" & wsThatLRow).Formula = "='" & wsOther.Name & "'!B2"
End With
End Sub
Related
Using VBA, I am trying to search for each value in column A of sheet 1, and match it with column A of sheet 2. If a value is found in sheet 2, update column B to "Yes"
Sheet 1
Sheet 2
So far I have:
Sub UpdateStatus()
Dim list() As Variant
Dim item As Integer
'Assign range to a variable
list = Range("A1:A" & Range("A" & Rows.Count).End(xlUp).Row)
'Loop Through Rows
For item = 1 To UBound(list)
'this is where I am stuck
Next item
End Sub
Sheet 2 should look like this afterwards:
Why loop if you can use Excel's engine?
Solution using Excel formulas
Sub Update_Status()
Dim Formula As String
Dim searchRng As Range
Dim valueRng As Range
Dim statusRng As Range
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Set ws1 = Worksheets("Sheet1")
Set ws2 = Worksheets("Sheet2")
Set valueRng = ws1.Range("A2:A" & LastRow("A", ws1)) ' A2, since you have header
Set searchRng = ws2.Range("A1:A" & LastRow("A", ws2))
Set statusRng = valueRng.Offset(0, 1)
' =IF(COUNTIFS(Sheet2!$A$2:$A$4,Sheet1!A2),"Yes","No")
Formula = "=IF(COUNTIFS(" & _
searchRng.Address(True, True) & "," & _
valueRng.Cells(1, 1).Address(False, False) & _
"),""Yes"",""No"")"
statusRng.Formula = Formula
' In case calculation is turned off
Application.Calculate
' If we prefer hardcoded values
statusRng.Copy
statusRng.PasteSpecial xlPasteValues
Application.CutCopyMode = False ' Flush clipboard
End Sub
Private Function LastRow(Col As String, Ws As Worksheet) As Long
LastRow = Ws.Range(Col & Rows.Count).End(xlUp).Row
End Function
This seems to work:
Sub UpdateStatus()
Dim list() As Variant
Dim item As Integer
Dim FoundCell As Range
Dim SearchValue As String
Dim Sheet2 As Worksheet
Set Sheet2 = Worksheets("Sheet2")
'Assign range to a variable
list = Range("A1:A" & Range("A" & Rows.Count).End(xlUp).Row)
'Loop Through Rows
For item = 1 To UBound(list)
SearchValue = list(item, 1)
Set FoundCell = Sheet2.Range("A2:A6").Find(What:=SearchValue)
If Not FoundCell Is Nothing Then
Sheet2.Range("B" & FoundCell.Row).Value = "Yes"
Else
MsgBox (SearchValue & " not found")
End If
Next item
End Sub
I wan't to transfer data within a range from each worksheet of a workbook excluding specific worksheet names based on a value being greater than zero within a range. Based on the value being greater than zero I wan't to transfer corresponding column values in the same row and update the database sheet by putting the values under specific columns from all worksheets apart from specific sheet and populate the list in the database sheet. My code does not seem to be working.
Sub Button4_Click()
Dim sourceRng As Range
Dim cell As Range
Dim i As Long
Dim ws As Worksheet
Dim wsC As Worksheet
Set wsC = Sheets("Database")
For Each wkSht In ThisWorkbook.Worksheets
If ws.Name <> "Database" And ws.Name <> "Combine" And ws.Name <> "CETIN" Then
Set sourceRng = ActiveSheet.Range("AY17:AY30")
i = 1
For Each cell In sourceRng
If cell.Value > 0 Then
cell.Resize(1, 1).Copy Destination:=wsD.Range("A" & i)
i = i + 1
End If
Next cell
End If
Next
End Sub
I believe this should work for you. Your image is hard to read, so you may need to adjust the columns if I read them wrong.
Option Explicit
Sub Button4_Click()
Dim i As Long
Dim wkSht As Worksheet
Dim wsC As Worksheet
Dim rowCount As Integer
Dim nextEmptyRow As Integer
Set wsC = ThisWorkbook.Worksheets("Database")
For Each wkSht In ThisWorkbook.Worksheets
nextEmptyRow = wsC.Cells(Rows.Count, "A").End(xlUp).Row + 1
If wkSht.Name <> "Database" And wkSht.Name <> "Combine" And wkSht.Name <> "CETIN" Then
For i = 17 To 30
If wkSht.Range("AY" & i).Value > 0 Then
wkSht.Range("AY" & i).Copy Destination:=wsC.Range("A" & nextEmptyRow)
wkSht.Range("K" & i).Copy Destination:=wsC.Range("B" & nextEmptyRow)
wkSht.Range("R" & i).Copy Destination:=wsC.Range("C" & nextEmptyRow)
wkSht.Range("T" & i).Copy Destination:=wsC.Range("D" & nextEmptyRow)
End If
Next i
End If
Next wkSht
End Sub
You can also replace wkSht.Range("AY" & i).Copy Destination:=wsC.Range("A" & nextEmptyRow) with wsC.Range("A" & nextEmptyRow).value = wkSht.Range("AY" & i).value for those 4 lines if you only want to preserve the value and not formatting.
I have an Excel sheet with 50,000+ rows of data from A:N. I have a Master Data Sheet that has a query in the BackupData worksheet. I currently copy that data and paste as values into the Backup worksheet. With the headers:
ID
Vendor #
Name
Customer #
Customer
Invoice #
Date
Item#
Item Description
Qty
B/C
Lbs
Amt
Amt#2
I am trying to loop through all of these rows and copy the range of cells A:N until the first value change in Column A, the first different ID #.
I then need to paste the selected range into a new workbook.
Basically, I want to do the opposite of consolidating.
Sub inserting()
Dim wsBData, wsExport, wsCoverSht, wsBackup As Worksheet
Dim wbAllRebates, wbSingle As Workbook
Set wbAllRebates = ActiveWorkbook
Set wsBData = wbAllRebates.Sheets("BackupData")
Set wsBackup = wbAllRebates.Sheets("Backup")
Dim rID, rTopRow As Range
Dim i As Long
Dim Counter As Integer
i = 3
Set rTopRow = Rows(1)
Set rID = wsBackup.Range("A1")
wsBData.Cells.Copy
wsBackup.Cells.PasteSpecial Paste:=xlPasteValues
Counter = 0
LastRow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
Do
If rID.Offset(i).Value <> rID.Offset(i - 1).Value Then
Rows(rID.Offset(i).Row).Insert shift:=xlDown
Call SubTotals(rID.Offset(i), rTopRow)
i = i + 1
Set rTopRow = Rows(rID.Offset(i).Row)
End If
Exit Do
Loop
MsgBox i
End Sub
Sub SubTotals(rID As Range, firstRow As Range)
rID.Value = "Total"
rID.Offset(, 9).Value = Application.WorksheetFunction.Sum(Range(firstRow.Cells(1, 10).Address & ":" & rID.Offset(-1, 1).Address))
End Sub
Try
Option Explicit
Sub SeparateWB()
Dim wsBData As Worksheet, wsBackup As Worksheet, wb As Workbook
Dim wbAllRebates As Workbook, rngHeader As Range
Dim i As Long, n As Long, LastRow As Long, StartRow As Long
Set wbAllRebates = ActiveWorkbook
With wbAllRebates
Set wsBData = .Sheets("BackupData")
Set wsBackup = .Sheets("Backup")
End With
wsBData.Cells.Copy
wsBackup.Cells.PasteSpecial Paste:=xlPasteValues
StartRow = 2
Application.ScreenUpdating = False
With wsBackup
LastRow = .Range("A" & .Rows.Count).End(xlUp).Row
Set rngHeader = .Range("A1:N1")
For i = 2 To LastRow
' change ID next row
If .Cells(i, "A") <> .Cells(i + 1, "A") Then
' create new workbook
Set wb = Workbooks.Add(1)
rngHeader.Copy wb.Sheets(1).Range("A1")
.Range("A" & StartRow & ":N" & i).Copy wb.Sheets(1).Range("A2")
wb.SaveAs .Cells(i, "A") & ".xlsx"
wb.Close False
' move to next
StartRow = i + 1
n = n + 1
End If
Next
End With
Application.ScreenUpdating = True
MsgBox n & " workbooks created"
End Sub
I'm really new to Excel VBA but recently need to come up with a solution to have excel iterate through a list and print the output.
Here on tab "Sheet2" is the item master. Each of the items is designated an Item Code.
On "Sheet1" I have a formula that finds the Unit Price and Starting Level and calculates the Total On Hand Liabilities.
I'd like to have Excel populate in cell Sheet1!A2 with each of the values in range Sheet2!A1:A, do the calculations, and paste all each of the outputs in a new sheet, as shown below.
Thank you.
I made a basic macro to do this, maybe you could tweak it to suit your needs.
Option Explicit
Sub Test()
Dim rng As Range
Dim switch As Boolean
switch = False
For Each rng In Worksheets("Sheet2").Range("A2", Worksheets("Sheet2").Range("A" & Rows.Count).End(xlUp))
Worksheets("Sheet1").Select
Range("A" & Rows.Count).End(xlUp).Select
'so that for the first iteration it will not offset, assuming you start off with blank wksht
If switch = True Then
ActiveCell.Offset(2, 0).Select
End If
ActiveCell.Value = "Item Number"
ActiveCell.Offset(0, 1).Value = "Description"
ActiveCell.Offset(0, 2).Value = "On Hand Liability"
ActiveCell.Offset(1, 0).Value = rng.Value
ActiveCell.Offset(1, 1).Value = rng.Offset(0, 1).Value
ActiveCell.Offset(1, 2).Value = rng.Offset(0, 2) * rng.Offset(0, 3)
switch = True
Next rng
End Sub
Suggest you use the Microsoft VBA language reference to look up loops. E.g. https://learn.microsoft.com/en-us/office/vba/language/reference/user-interface-help/for-eachnext-statement
Here is an example which will produce your output:
Option Explicit
Public Sub PopulateSheet1()
Dim SourceSheet As Worksheet
Dim SourceRow As Range
Dim SourceRows As Long
Dim TargetSheet As Worksheet
Dim TargetRow As Long
Set SourceSheet = ActiveWorkbook.Sheets("Sheet2")
Set TargetSheet = ActiveWorkbook.Sheets("Sheet1")
SourceRows = SourceSheet.Cells(Rows.Count, 1).End(xlUp).Row
TargetRow = 1
For Each SourceRow In SourceSheet.Range("A2:A" & SourceRows)
TargetSheet.Cells(TargetRow, 1) = Array("Item Number", "Description", "On Hand Liability")
TargetRow = TargetRow + 1
SourceRow.Cells(1, 1).Copy TargetSheet.Cells(TargetRow, 1)
TargetSheet.Cells(TargetRow, 2) = "=VLOOKUP(Sheet1!A" & TargetRow & ",Sheet2!A:B,2,FALSE)"
TargetSheet.Cells(TargetRow, 3) = "=VLOOKUP(Sheet1!A" & TargetRow & ",Sheet2!A:D,3,FALSE) * VLOOKUP(Sheet1!A" & TargetRow & ",Sheet2!A:D,4,FALSE)"
TargetSheet.Cells(TargetRow, 3).NumberFormat = "$#,##0.00"
TargetRow = TargetRow + 2
Next
End Sub
I need an excel vba code which copy the data from one sheet and paste it on the other sheet if the given conditions satisfied. There will be two sheets in a workbook (sheet1 and sheet 2). Basically the data in sheet 2 column "C" must be copy to sheet 1 column "C".
The conditions are : -
There will be three columns in SHEET 1&2 A,B,C .
IF SHEET 1 B1 has a data let us take("88").Now,it should search how many of them ("88") are there in sheet2 B:B.
If there are more than one let us take "4" then those "4" sheet2 "C" values are belongs to the sheet 1
"A1". It should create another three rows with "sheet1 A1 & B1" Value then those 4 values must be
paste in "sheet1 "c" beside those four "Sheet A1&B1". iam unable to select those 4 SHEET2 "C" VALUES
If there is one "88" then it can just paste at sheet1"C1".
In this way it should do for every value in sheet 1 B:B.
At least Tell me what code is used to add rows with cell value through vba
How To Find Value & Copy Corresponding Cell
Sub copythedata()
Dim r As Long, ws As Worksheet, wd As Worksheet
Dim se As String
Dim sf As String
Dim fn As Integer
Dim y As Integer
Dim lrow As Long
Set ws = Worksheets("sheet2")
Set wd = Worksheets("sheet1")
y = 123
x = wd.Cells(Rows.Count, 1).End(xlUp).Row
MsgBox "Last Row: " & x
If x > y Then
wd.Range(wd.Cells(y, 1), wd.Cells(x, 1)).EntireRow.Delete Shift:=xlUp
End If
For r = wd.Cells(Rows.Count, "B").End(xlUp).Row To 2 Step -1
fn = Application.WorksheetFunction.countif(ws.Range("B:B"), wd.Range("B" & r).Value)
If fn = 1 Then
wd.Range("C" & r).Value = ws.Range("C" & r).Value
ElseIf fn > 1 Then
se = wd.Range(wd.Cells(A, r), wd.Cells(B, r)).EntireRow.Copy
wd.Range("A123").Rows(fn - 1).Insert Shift:=xlShiftDown
Else
wd.Range("C" & r).Value = "NA"
End If
Next r
End Sub
See Find and
FindNext
When using FindNext see the Remarks section for how to stop search after the 'wraparound' to the start, otherwise you get into an endless loop.
Option Explicit
Sub copythedata()
Dim wb As Workbook, ws1 As Worksheet, ws2 As Worksheet
Dim iLastRow1 As Integer, iLastRow2 As Long
Dim iRow As Integer, iNewRow As Long, iFirstFound As Long
Dim rngFound As Range, rngSearch As Range
Dim cell As Range, count As Integer
Set wb = ThisWorkbook
Set ws1 = wb.Sheets("Sheet1")
Set ws2 = wb.Sheets("sheet2")
' sheet 2 range to search
iLastRow2 = ws2.Range("B" & Rows.count).End(xlUp).Row
Set rngSearch = ws2.Range("B1:B" & iLastRow2)
'Application.ScreenUpdating = False
' sheet1 range to scan
iLastRow1 = ws1.Range("B" & Rows.count).End(xlUp).Row
' add new rows after a blank row to easily identify them
iNewRow = iLastRow1 + 1
For iRow = 1 To iLastRow1
Set cell = ws1.Cells(iRow, 2)
Set rngFound = rngSearch.Find(what:=cell.Value, _
LookIn:=xlValues, LookAt:=xlWhole, SearchDirection:=xlNext)
If rngFound Is Nothing Then
'Debug.Print "Not found ", cell
cell.Offset(0, 1) = "NA"
Else
iFirstFound = rngFound.Row
Do
'Debug.Print cell, rngFound.Row
If rngFound.Row = iFirstFound Then
cell.Offset(0, 1) = rngFound.Offset(0, 1).Value
Else
iNewRow = iNewRow + 1
ws1.Cells(iNewRow, 1) = cell.Offset(, -1)
ws1.Cells(iNewRow, 2) = cell.Offset(, 0)
ws1.Cells(iNewRow, 3) = rngFound.Offset(0, 1).Value
End If
Set rngFound = rngSearch.FindNext(rngFound)
Loop Until rngFound.Row = iFirstFound
End If
Next
Application.ScreenUpdating = True
MsgBox "Finished", vbInformation
End Sub