I have a workbook with a master sheet called "NIR" containing the following data: Column A contains product names(the same as the rest of the worksheets names);Column B contains quantity and Column C contains prices.
I want to create a VBA to search in my master sheet "NIR" in Column A and copy Columns B and C to specific sheets according to master sheet "NIR" ,cells in Column A.
Example:
Sheet "NIR"
A3="shoes"
A4="pants"
B3 = 3 (pairs)
C3 = 10 (price)
copy B3 and C3 to sheets "shoes" and "pants"according to Sheet"NIR" A3
Try:
Option Explicit
Sub Macro1()
Dim LastRowNIR As Long, i As Long, LastRowWs As Long
Dim arr As Variant
With ThisWorkbook.Worksheets("NIR")
'Find the last row of column A
LastRowNIR = .Cells(.Rows.Count, "A").End(xlUp).Row
'Import all data in an array starting from A1 to C last row
arr = .Range("A1:C" & LastRowNIR)
'Loop array
For i = LBound(arr) To UBound(arr)
With ThisWorkbook.Worksheets(arr(i, 1))
'Find the last row of column B
LastRowWs = .Cells(.Rows.Count, "B").End(xlUp).Row
'Write in the next available row the quantity
.Range("B" & LastRowWs + 1).Value = arr(i, 2)
'Write in the next available row the prices
.Range("C" & LastRowWs + 1).Value = arr(i, 3)
End With
Next i
End With
End Sub
Related
I am stuck i don't know what code to use so i can search the same column twice for 2 different keyword and then copy data from the same row to another spreadsheet in sequence from a start cell. for details here's what i am trying to do.
Limit the search within a range of the worksheet (ex. Sheet 1 B1:N:200)
Search the 8th column (I) of the limit range Sheet1 for keyword ("Goods")
Copy the data found in the 2nd (C) and 5th column (F) of same row where instance "Goods " is found
Paste Value of Sheet 1 - column 2 to Sheet2 - Column 3 (no format values only), and Sheet 1 column 5 to Sheet 2 Column4 (with format and values) on a specific starting point (ex. Sheet 2 - B3) Next Match Result will be Sheet 2 - B4 and so on
5.Search AGAIN the 8th column of Sheet1 for keyword ("Services") starting from the top (B1:N1)
6.Copy the data found in the 2nd (C) and 5th column (F) of same row where instance "Services" is found
Paste Value of Sheet 1 - column 2 to Sheet2 - Column 3 (no format values only), and Sheet 1 column 5 to Sheet 2 Column4 (with format and values) to next row after the last PASTE from "Goods" was done. (ex last row match paste was C35 and D35 new found value should be paste in C36 a D36)
Ending Output should be all "Goods" results first then "Services" results
I hope i have conveyed what i need clearly
I am trying to work on this code that i found here but i just don't get how to insert the 2nd search loop for services., how to paste on specific cell in sheet2, how to follow the last row for services paste
Sub CopyCells
Dim lngLastRowSht1 As Long
Dim lngLastRowSht2 As Long
Dim counterSht1 As Long
Dim counterSht2 As Long
With Worksheets(1)
lngLastRowSht1 = .Cells(.Rows.Count, 8).End(xlUp).Row
lngLastRowSht2 = Worksheets(2).Cells(Worksheets(2).Rows.Count, 5).End(xlUp).Row
For counterSht1 = 1 To lngLastRowSht1
For counterSht2 = 1 To lngLastRowSht2
If Sheets(1).Range("" & (counterSht1)).Value = "Goods" Then
Sheets(2).Range("B" & (counterSht2), "D" & (counterSht2)).Value = Sheets(1).Range("C" & counterSht1, "D" & counterSht1).Value
End If
Next counterSht2
Next counterSht1
End With
End Sub
Edit1
As per request of sir Chris this is how it should look like
Answer for this Query was best solved by #CDP1802 Worked as needed.
I learned that I needed 2 counters for it to work :) and I also learned how to properly label target destination.
Thank you for this community:)
Increment the target row after each copy.
Option Explicit
Sub CopyCells()
Const ROW_START = 3
Dim wb As Workbook, ws1 As Worksheet, ws2 As Worksheet
Dim n As Long, r As Long, lastrow1 As Long, lastrow2 as Long
Dim keywords, word, t0 As Single: t0 = Timer
keywords = Array("Goods", "Services")
Set wb = ThisWorkbook
Set ws1 = wb.Sheets(1)
Set ws2 = wb.Sheets(2)
lastrow2 = ROW_START
Application.ScreenUpdating = False
With ws1
lastrow1 = .Cells(.Rows.Count, "I").End(xlUp).Row
For Each word In keywords
For r = 1 To lastrow1
If Len(.Cells(r, "I")) = 0 Then
Exit For
ElseIf .Cells(r, "I") = word Then
'Sht1 col 2 to Sht2 Col 3 (no format values only)
'Sht1 col 5 to Sht2 Col 4 (with format and values)
ws2.Cells(lastrow2, "C") = .Cells(r, "B")
ws2.Cells(lastrow2, "D") = .Cells(r, "E")
.Cells(r, "E").Copy
ws2.Cells(lastrow2, "D").PasteSpecial xlPasteFormats
lastrow2 = lastrow2 + 1
n = n + 1
End If
Next
Next
End With
Application.ScreenUpdating = True
MsgBox r - 1 & " rows scanned " & vbLf & n & " rows copied", _
vbInformation, Format(Timer - t0, "0.0 secs")
End Sub
You could make two routines: one for services and one for goods. But that code and the code above isn't very efficient.
Since Services & Goods are in the same column, try using the autofilter:
Sheets(2).UsedRange.autofilter Field:=8, Criteria1:=Array("Goods", "Services"), VisibleDropDown:=False, Operator:=xlFilterValues
Sheets(2).UsedRange.SpecialCells(xlCellTypeVisible).Copy
Sheets(1).Range("A1").PasteSpecial
Application.CutCopyMode = False
Name manager using vba ...
I need to get the cell value from the column one by one and have to declare that name to that row range next to that column
Example
In column D I have the name list
I have to get that D1 value and declare that value to the row range ( E1:S1 )
Next
have to D2 ---> E2:S2
This is how it should be done for first 5 rows:
For i = 1 To 5
ThisWorkbook.Names.Add Name:=yourWorksheet.Cells(i, 4).Value, RefersTo:=yourWorksheet.Range(yourWorksheet.Cells(i, 5), yourWorksheet.Cells(i, 19))
Next
remember that the names must be unique
Try following code
Sub AddNamedRange()
Dim cel As Range
Dim ws As Worksheet
Dim lastRow As Long
Set ws = ThisWorkbook.Sheets("Sheet4") 'change Sheet4 to your sheet name
With ws
lastRow = .Cells(.Rows.Count, "D").End(xlUp).Row 'last row with data in Column D
For Each cel In .Range("D1:D" & lastRow) 'loop through all cell in Column D
ThisWorkbook.Names.Add cel, ws.Range(cel.Offset(, 1), cel.Offset(, 15)) 'adding named range
Next
End With
End Sub
I have a value in Column A which I want to write to a separate sheet, there are column and row numbers which specify the location I want to write that value in the same row as the value in column A.
For instance the value in A8 has column number "2" in Q8 and row number "118" in S8. So I want to write a formula in the new sheet which puts the value of A8 into cell B118 in the new sheet. And for this to go down with all the values in A:A as the first sheet continues to be filled in.
I've tried doing this with sumifs formula here but its not quite working out;
=IF(SUMIFS(sheet1!$A:$A,sheet1!$Q:$Q,COLUMN(B8),sheet1!$S:$S,ROW(B8))," ",sheet1!$A:$A)
If you want the formula in the new sheet to reference the cell in Sheet1 then:
Sub marine()
Dim cl As Long, rw As Long, source As String
cl = Range("Q8").Value
rw = Range("S8").Value
Sheets("new").Cells(rw, cl).Formula = "=Sheet1!A8"
End Sub
and if you simply want A8's value transferred to the new sheet, then:
Sub marine2()
Dim cl As Long, rw As Long, source As String
cl = Range("Q8").Value
rw = Range("S8").Value
Sheets("new").Cells(rw, cl).Value = Range("A8").Value
End Sub
EDIT#1:
Here is a version that will handle the entire column:
Sub marine3()
Dim cl As Long, rw As Long, source As String
Dim i As Long, N As Long
N = Cells(Rows.Count, "A").End(xlUp).Row
For i = 8 To N
cl = Range("Q" & i).Value
rw = Range("S" & i).Value
If cl <> 0 And rw <> 0 Then
Sheets("new").Cells(rw, cl).Value = Range("A" & i).Value
End If
Next i
End Sub
Here is my answer.
Sub movindData()
'take all the data from sheet1 and move it to sheet2
Dim sht2 As Worksheet
Dim r
Dim c
Dim i
Dim rng As Range
Dim A 'for each value in column A
Dim Q 'for each value in column Q (the column)
Dim S 'for each value in column S (the row)
r = Range("A1").End(xlDown).Row 'the botton of columns A, the last row
'I take the inicial cells as a A1, but you
'can change it as you need.
c = 1 'the column A
Set rng = Range(Cells(1, 1), Cells(r, c)) 'this takes just the range with the data in columns A
Set sht2 = Sheets("Sheet2")
For Each i In rng
A = i.Value 'Store the value of every cell in column A
Q = i.Offset(0, 16).Value 'Store the value of every cell in column Q (the destination column in sheet2)
S = i.Offset(0, 18).Value 'Store the value of every cell in column s (the destination row in sheet2)
sht2.Cells(Q, S).Value = A
Next i
End Sub
I have two worksheets in the same workbook. In Sheet1 Column 1 is of expected stock barcodes, in Sheet2, Column 2 is comprised of the barcodes which I scanned.
I wrote a formula in conditional formatting to check items Column 2 and color them if they are not in Column 1, but I don't want to have to scroll through the entire list to see this.
What I want to do is populate a third (and fourth for quantity) column with only entries that are in Column 2 and not Column 1, and if possible, list the number of times it was found in Column 2.
Example:
Column 1
bc123
bc1234
bc12345
bc123456
bc1234567
Column 2
bc12345
bc123456
bc56789
bc67890
bc67890
Column 3 (Automatically populated with unique entries from column 2)
bc56789 1
bc67890 2
Thank you!
Here, my VBA approach for your problem:
Public Sub findAndCount()
Dim sh1, sh2 As Worksheet
Dim foundCell As Range
Dim startSheet2, resultRow As Integer
'Set sheets
Set sh1 = Sheets("Sheet1")
Set sh2 = Sheets("Sheet2")
'Set the start row of column from Sheet2
startRow = 1
resultRow = 1
'Clear old result from column C & D of Sheet1
sh1.Range("C:D").ClearContents
'Loop all row of column 2 from Sheet2 until blank
Do While sh2.Range("B" & startRow) <> ""
'Find value in column A of Sheet1
Set foundCell = sh1.Range("A:A").Find(sh2.Range("B" & startRow), LookIn:=xlValues)
'If match value is not found
If foundCell Is Nothing Then
'Find result is already exist or not
Set foundCell = sh1.Range("C:C").Find(sh2.Range("B" & startRow), LookIn:=xlValues)
'If result is not exist, add new result. (Here, I show result in Sheet1, you can change it.)
If foundCell Is Nothing Then
'Set barcode
sh1.Range("C" & resultRow) = sh2.Range("B" & startRow)
'Set count
sh1.Range("D" & resultRow) = 1
'Increase result row
resultRow = resultRow + 1
'If already exist
Else
'Increase count
foundCell.Offset(0, 1) = foundCell.Offset(0, 1).Value + 1
End If
End If
'Increase row
startRow = startRow + 1
Loop
End Sub
I have fours lists in Excel of arbitraty lenght.
A B C D
A1 B1 C1 D1
A2 B2 C2 D2
A3 B3 D3
A4 D4
D5
I want to create one table that has every combination from the lists as rows.
A B C D
A1 B1 C1 D1
A1 B1 C1 D2
...
A4 B3 C2 D5
Is there any simple way to do this in Excel - using Excel functionality, formulas or VBA?
If you have your four lists next to each other, highlight the data and insert a pivot table.
Add each of the columns to the "rows" section of the pivot table.
Right-click on each field in turn and click on "Field Settings".
Set the Layout and print to show tabular form, repeated item labels and items with no data as follows.
And this is the resulting table.
I suspect you'll want to delete the rows which contain 1 or more (blank) rows.
This is probably easiest by adding a formula to column E along the lines of
=IF(A2="(blank)",1,0)
Repeat this for the other columns, Add them up and sort by the total.
Delete all rows that have a non-zero entry.
Some nested for statements should handle this problem. Just put this in the VBA for your project and it will create a macro called CreateTable() which should put the table in a new worksheet for you.
Sub CreateTable()
'Creates a table will all combinations of values from four columns
Dim a, b, c, d As Range
'Activates sheet that has data on it to be copied to table
Worksheets("Sheet1").Activate 'Change Sheet1 to the name of your sheet
'Change A2 to first cell of data you want to be copied over
Set a = Range("A2", Range("A2").End(xlDown))
Set b = Range("B2", Range("B2").End(xlDown))
Set c = Range("C2", Range("C2").End(xlDown))
Set d = Range("D2", Range("D2").End(xlDown))
Dim i As Integer
i = 1 'Row number of the first row of data for the table of combinations
Worksheets("Sheet2").Activate 'Change Sheet2 to name of sheet you want the table to be put on
For Each cellA In a.Cells
For Each cellB In b.Cells
For Each cellC In c.Cells
For Each cellD In d.Cells
Worksheets("Sheet2").Cells(i, 1) = cellA.Value
Worksheets("Sheet2").Cells(i, 2) = cellB.Value
Worksheets("Sheet2").Cells(i, 3) = cellC.Value
Worksheets("Sheet2").Cells(i, 4) = cellD.Value
i = i + 1
Next cellD
Next cellC
Next cellB
Next cellA
End Sub
You should show what you've tried already and give specifics of where your data is coming from, but here's a VBA solution. Loops through each item in a given column, for as many rows as there are total combinations of items.
Sub Combination_Table()
Dim rList1 As Range
Dim rList2 As Range
Dim rList3 As Range
Dim rList4 As Range
Dim lLength1 As Long
Dim lLength2 As Long
Dim lLength3 As Long
Dim lLength4 As Long
Dim lRowcounter As Long
Sheets(1).Activate
With Sheets(1)
lLength1 = .Range("A" & .Rows.Count).End(xlUp).Row - 1
lLength2 = .Range("B" & .Rows.Count).End(xlUp).Row - 1
lLength3 = .Range("C" & .Rows.Count).End(xlUp).Row - 1
lLength4 = .Range("D" & .Rows.Count).End(xlUp).Row - 1
Set rList1 = .Range("A2:A" & lLength1)
Set rList2 = .Range("B2:B" & lLength2)
Set rList3 = .Range("C2:C" & lLength3)
Set rList4 = .Range("D2:D" & lLength4)
End With
'The above marks the ranges containing the original un-combined lists,
'with no duplicates and assuming row 1 is the header and all data is on
'columns A-D, without blanks.
rowcounter = 0
Sheets(2).Activate
For i = 1 To lLength1
For j = 1 To lLength2
For k = 1 To lLength3
For l = 1 To lLength4
rowcounter = rowcounter + 1
Sheets(2).Range("A" & rowcounter).Formula = rList1(i, 1).Text
Sheets(2).Range("B" & rowcounter).Formula = rList2(j, 1).Text
Sheets(2).Range("C" & rowcounter).Formula = rList3(k, 1).Text
Sheets(2).Range("D" & rowcounter).Formula = rList4(l, 1).Text
'This changes the text in columns A-D for the given rowcount, to the current
'iteration of the current looped value from the above lists
Next l
Next k
Next j
Next i
End Sub
This Works too and this is simpler.
Sub t()
Dim sht As Worksheet
Dim LastRow As Long, lastcol As Long
Dim i As Integer, j As Integer, k As Integer
Set sht = ThisWorkbook.Sheets("Sheet1")
LastRow = sht.Range("A1").CurrentRegion.Rows.Count
lastcol = sht.Range("A1").CurrentRegion.Columns.Count
k = 0
For i = 2 To LastRow
j = 1
k = k + 1
For j = 1 To lastcol
sht.Cells(i, j).Value = sht.Cells(1, j) & k
Next
Next
End Sub