I'm trying to fill formulas in column C like this:
LastRow = Range("A65536").End(xlUp).Row
Range(Cells(1, 3), Cells(LastRow, 3)).Formula = "=A1*B1"
And it works fine. But is it possible to skip those cells in column C, which value is for example > 0 ?
A B C -> A B C
3 2 0 3 2 6
3 4 0 3 4 12
5 6 5 5 6 5 <- this value is not updated
For this you will have to do a slight change to how your data looks like. For example, you need to add "Header" to the first row. The reason we would do that is because we would be using AutoFilter
Let's say your data looks like this
Now use this code
Sub Sample()
Dim ws As Worksheet
Dim copyFrom As Range
Dim lRow As Long
'~~> Change this to the relevant sheet
Set ws = ThisWorkbook.Worksheets("Sheet1")
With ws
'~~> Remove any filters
.AutoFilterMode = False
'~~> Get lastrow in column c
lRow = .Range("C" & .Rows.Count).End(xlUp).Row
'~~> Filter the col C to get values which have 0
With .Range("C1:C" & lRow)
.AutoFilter Field:=1, Criteria1:="=0"
Set copyFrom = .Offset(1, 0).SpecialCells(xlCellTypeVisible)
'~~> Assign the formula to all the cells in one go
If Not copyFrom Is Nothing Then _
copyFrom.Formula = "=A" & copyFrom.Row & "*B" & copyFrom.Row
End With
'~~> Remove any filters
.AutoFilterMode = False
End With
End Sub
Output
One way to do it through loop :
Sub test()
Dim rngTest As Range
Dim rngCell As Range
LastRow = Range("A65536").End(xlUp).Row
Set rngTest = Range(Cells(1, 3), Cells(LastRow, 3))
Application.Calculation = xlCalculationManual
For Each rngCell In rngTest.Cells
If Not rngCell <> "" Then
rngCell.Formula = "=" & rngCell.Offset(, -2).Address & "*" & rngCell.Offset(, -1).Address
End If
Next
Application.Calculation = xlCalculationAutomatic
End Sub
Related
I have a workbook with 3 sheets: first one is the raw data sheet, then 2 target sheets. I would need a macro that would look at cell C in raw data sheet and based on the 2 values (YES or NO), will copy and paste the range A:Y in sheets 2, respectively 3.
Example: if on C2 in raw data sheet i have YES, copy A2:Y2 and paste into sheet 2, same range A2:Y2. If instead i have the value NO, copy A2:Y2 and paste into sheet 3.
Then go to next row and copy-paste A3:Y3 to sheet 2 if YES or A3:Y3 to sheet 3 if NO.
I wrote something that only works for the 2nd row, but i don't know how to make it loop... so basically when it passes to the next rows, it still copies the values from A2:Y2 to the target sheet, instead of copying A3:Y3, A4:Y4 etc..
Pasting my poor code below:
Sub IdentifyInfraction()
Dim rngA As Range
Dim cell As Range
Set rngA = Range("C2", Range("C65536").End(xlUp))
For Each cell In rngA
Worksheets("raw_data").Select
If cell.Value = "YES" Then
Range("A2:Y2").Copy
Worksheets("Value_YES").Select
Range("A2").PasteSpecial Paste:=xlPasteValues
ElseIf cell.Value = "NO" Then
Range("A2:Y2").Copy
Worksheets("Value_NO").Select
Range("A2").PasteSpecial Paste:=xlPasteValues
End If
Next cell
End Sub
Please help!!! :-s
Easiest solution would just be to replace the number 2 in each of your ranges to a variable which you then increment at the end your statement, before you go to the next cell.
For example:
Dim i = 2
Set rngA = Range("C2", Range("C65536").End(xlUp))
For Each cell In rngA
Worksheets("raw_data").Select
If cell.Value = "YES" Then
Range("A" & i & ":Y" & i).Copy
Worksheets("Value_YES").Select
Range("A" & i).PasteSpecial Paste:=xlPasteValues
ElseIf cell.Value = "NO" Then
Range("A" & i & ":Y" & i).Copy
Worksheets("Value_NO").Select
Range("A" & i).PasteSpecial Paste:=xlPasteValues
End If
i = i + 1
Next cell
So, originally we set i = 2, this is to go in line with your starting row of 2 mentioned in your question. Then, Range("A" & i & ":Y" & i).Copy is the same as saying Range("A2:Y2").Copy or Range("A3:Y3").Copy, etc.
This will go through any copy each row, a new row each time, and paste it to the respective row in the various sheets.
I hope this works for what you are trying to do, if not let me know.
There are a few things I'd also recommend looking into. There's a much better way to copy and paste, without going back and forward through the sheets.
ThisWorkbook.Sheets("raw_data").Rows(i).Copy Destination:=Worksheets("Value_YES").Range("A" & i)
Something like this would take the whole row from raw_data and transfer it to Value_YES. You'd have to mess around with it and change the range from Rows(i), but that's just an example.
I'd also recommend that you look into How to avoid using Select in Excel VBA to better understand why it's frowned upon to use Select and Activate in Excel VBA.
My version:
Sub GetR_Done()
Dim rng As Range, c As Range, LstRw As Long
Dim ws As Worksheet, Nr As Long, Yr As Long
Dim Ys As Worksheet, Ns As Worksheet
Set ws = Sheets("raw_data")
Set Ys = Sheets("Value_YES")
Set Ns = Sheets("Value_NO")
With ws
LstRw = .Cells(.Rows.Count, "C").End(xlUp).Row
Set rng = .Range("C2:C" & LstRw)
For Each c In rng.Cells
If c = "YES" Then
With Ys
Yr = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
End With
.Range(.Cells(c.Row, "A"), .Cells(c.Row, "Y")).Copy Ys.Range("A" & Yr)
End If
If c = "NO" Then
With Ns
Nr = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
End With
.Range(.Cells(c.Row, "A"), .Cells(c.Row, "Y")).Copy Ns.Range("A" & Nr)
End If
Next c
End With
End Sub
If you really require to paste values, then use this one
Sub GetR_Done()
Dim rng As Range, c As Range, LstRw As Long
Dim ws As Worksheet, Nr As Long, Yr As Long
Dim Ys As Worksheet, Ns As Worksheet
Set ws = Sheets("raw_data")
Set Ys = Sheets("Value_YES")
Set Ns = Sheets("Value_NO")
Application.ScreenUpdating = False
With ws
LstRw = .Cells(.Rows.Count, "C").End(xlUp).Row
Set rng = .Range("C2:C" & LstRw)
For Each c In rng.Cells
If c = "YES" Then
With Ys
Yr = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
End With
.Range(.Cells(c.Row, "A"), .Cells(c.Row, "Y")).Copy
Ys.Range("A" & Yr).PasteSpecial xlPasteValues
End If
If c = "NO" Then
With Ns
Nr = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
End With
.Range(.Cells(c.Row, "A"), .Cells(c.Row, "Y")).Copy
Ns.Range("A" & Nr).PasteSpecial xlPasteValues
End If
Next c
End With
Application.CutCopyMode = False
End Sub
you could try this:
Sub IdentifyInfraction()
Dim cell As Range
With Worksheets("raw_data") 'reference "raw data" sheet
For Each cell In .Range("C2", .cells(.Rows.Count, "C").End(xlUp)) ' loop through referenced sheet column C cells from row 2 down to last not empty one
Worksheets("Value_" & cell.Value).Range(cell.Address).Resize(, 25).Value = cell.Resize(, 25).Value 'have proper target sheet A:Y current cell row values as "raw data" sheet ones
Next
End With
End Sub
I'm trying to find a solution to a second part of the code.
I have a table with 5 columns containing about 70 records (every time different number) and I need to create new spreadsheets (each tab is named as a record number in the first column) for each record where values for other records in the first two columns will be hidden(removed/deleted). The first row and the last row of the table shouldn't be hidden as they contain columns' headers and Total formulas (5th column contains formulas as well).
I've managed to create a code to solve the first part of the problem of creating spreadsheets with all data and changing names for those tabs. But I still cannot figure out how to keep only values for one record in a spreadsheet and hide/remove/delete values in the first two columns for other records.
Here is the code I have, would be grateful for any help!
Sub Create()
Dim I As Long
Dim xNumber As Integer
Dim xName As String
Dim ws As Worksheet
Dim rg As Range
Dim lastRow As Long
On Error Resume Next
Application.ScreenUpdating = False
Set ws = ActiveSheet
lastRow = ws.Range("B" & ws.Rows.Count).End(xlUp - 1).Row
Set rg = Range("A1:A" & lastRow)
xNumber = InputBox("Enter number of times to copy the current sheet")
For I = 1 To xNumber
xName = ActiveSheet.Name
ws.Copy After:=ActiveWorkbook.Sheets(xName)
ActiveSheet.Name = ws.Range("A" & I + 1).Value
With rg
.AutoFilter Field:=1, Criteria1:=ActiveSheet.Name
.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireColumn.Clear
End With
Next
ws.Activate
Application.ScreenUpdating = True
End Sub
Here is an answer with some code that will:
Loop through all your sheets
Looking for current sheet name (If not there then do nothing)
Delete/clear cells untill there is just the 3 rows left
Adjust to your liking
Sub DoStuff1()
Dim WS As Worksheet
Dim LR As Long, FR As Long
Dim CL As Range
Application.ScreenUpdating = False 'Turn the screen refresh off
For Each WS In ThisWorkbook.Sheets 'Loop through your sheets
WS.Activate
StartHere: LR = WS.Cells(Rows.Count, "A").End(xlUp).Row - 1 'Get the dynamic last used row
Set CL = WS.Columns(1).Find(What:=WS.Name, LookAt:=xlWhole, MatchCase:=False, SearchFormat:=False)
If Not CL Is Nothing Then
FR = CL.Row 'Get the row which is the value
If FR > 2 And FR < LR Then 'If larger than 2 but smaller than last used row then
WS.Range(Cells(2, 1), Cells(FR - 1, 2)).Delete Shift:=xlUp
GoTo StartHere
ElseIf FR = 2 And FR < LR Then 'If FR = 2 but still some rows between FR and LR
WS.Range(Cells(FR + 1, 1), Cells(LR, 2)).Delete Shift:=xlUp
GoTo StartHere
ElseIf FR = LR And FR > 2 Then 'If A is the lastrow with a value but rows between 2 and FR
WS.Range(Cells(2, 1), Cells(FR - 1, 2)).Delete Shift:=xlUp
GoTo StartHere
Else
'If there is only the startrow, the foundrow with value and the very last row left...
End If
End If
Next WS
Application.ScreenUpdating = True 'Turn the screen refresh back on
End Sub
EDIT: Second option, clearing cells instead of deleting
Sub DoStuff2()
Dim WS As Worksheet
Dim LR As Long, FR As Long
Dim CL As Range
Application.ScreenUpdating = False
For Each WS In ThisWorkbook.Sheets
WS.Activate
LR = WS.Cells(Rows.Count, "A").End(xlUp).Row - 1
Set CL = WS.Columns(1).Find(What:=WS.Name, LookAt:=xlWhole, MatchCase:=False, SearchFormat:=False)
If Not CL Is Nothing Then
FR = CL.Row
If FR > 2 And FR < LR Then WS.Range(Cells(2, 1), Cells(FR - 1, 2)).ClearContents
If FR < LR And FR > 2 Then WS.Range(Cells(FR + 1, 1), Cells(LR, 2)).ClearContents
If FR = 2 And FR < LR Then WS.Range(Cells(FR + 1, 1), Cells(LR, 2)).ClearContents
If FR = LR And FR > 2 Then WS.Range(Cells(2, 1), Cells(FR - 1, 2)).ClearContents
End If
Next WS
Application.ScreenUpdating = True
End Sub
from my master sheet (JV501) at the bottom most is a row which I need to copy in every sheet I've extracted so far. It needs to be copied also in every bottom of data.
futureuse | Price | Credit | Currency |
-------------------------------------------------------------------------------------------
300x | 6151500 | | EUR |
300x | 6151500 | | USD |
300x | 6151500 | 8896684.6 |
above is a sample data, the third row with the Credit needs to be copied in every data I've extracted, I've extracted sheets based on 'Currency Column'
Option Explicit
Sub SortCurrency()
Dim currRange As Range, dataRng As Range, currCell As Range
Call DeleteSheets
Dim lastcol As Long
Dim lastrow As Long
Dim lastrow2 As Long
Dim Idx As Variant
With Worksheets("JV501")
.Select
Set currRange = .Range("AB1", .Cells(.Rows.Count, "AB").End(xlUp))
Set dataRng = Intersect(.UsedRange, currRange.EntireRow)
lastcol = Range("A1").End(xlToRight).Column
lastrow = Range("AB2").End(xlDown).Row
Range("AB2:AB" & lastrow).sort key1:=Range("AB2" & lastrow), _
order1:=xlAscending, Header:=xlNo
With .UsedRange
.Resize(1, 1).Offset(0, lastcol - 1).Select
With .Resize(1, 1).Offset(0, lastcol)
With .Resize(currRange.Rows.Count)
.Value = currRange.Value
.RemoveDuplicates Array(1), Header:=xlYes
Range("AB:AB").Copy Destination:=Worksheets("Checklist").Range("A1")
For Each currCell In .SpecialCells(xlCellTypeConstants)
currRange.AutoFilter , field:=1, Criteria1:=currCell.Value
If Application.WorksheetFunction.Subtotal(103, currRange) - 1 > 0 Then
dataRng.SpecialCells(xlCellTypeVisible).Copy Destination:=GetOrCreateWorksheet(currCell.Value).Range("A1")
Range("A:A").EntireColumn.Delete
Range("J:Q").EntireColumn.Delete
Columns("A:V").Select
Selection.EntireColumn.AutoFit
End If
Next currCell
.ClearContents
End With
End With
End With
.AutoFilterMode = False
End With
End Sub
Function GetOrCreateWorksheet(shtName As String) As Worksheet
On Error Resume Next
Set GetOrCreateWorksheet = Worksheets(shtName)
If GetOrCreateWorksheet Is Nothing Then
Set GetOrCreateWorksheet = Worksheets.Add(After:=Sheets(Sheets.Count))
GetOrCreateWorksheet.Name = shtName
End If
End Function
Sub DeleteSheets()
Dim ws As Worksheet
Application.DisplayAlerts = False
For Each ws In Worksheets
If ws.Name <> "JV501" And ws.Name <> "details" And ws.Name <> "removed" And ws.Name <> "Checklist" Then ws.Delete
Next
Application.DisplayAlerts = True
End Sub
Sub countCurrency()
Dim sffCount As Long
Dim ws As Worksheet
Set ws = Sheets("Checklist")
Dim lastrow As Long
lastrow = ws.Range("A" & Rows.Count).End(xlUp).Row
Dim Idx As Variant
For Idx = 2 To lastrow
sffCount = Application.WorksheetFunction.CountIf(ws.Range("A1:A" & ws.Rows.Count), ws.Cells(Idx, "A").Value)
ws.Cells(Idx, "B") = sffCount
Next
End Sub
I'm sorry if it's quite long since I'm also try to get the count of my currency (Under Sub countCurrency) and copy to another sheet called "Checklist" which is also my problem I need to sort and filter also
Every help is very much appreciated!!!
got it working
With Worksheets("JV501")
Dim copyS As Range, copyR As Range,
Set copyR = Range("R" & Rows.Count).End(xlUp) 'find lastrow of column R
Set copyS = Range("S" & Rows.Count).End(xlUp)
then under my if loop
internalR = Range("R" & Rows.Count).End(xlUp).Row + 1
copyR.copy Destination:=Range("R" & internalR)
internalS = Range("S" & Rows.Count).End(xlUp).Row + 1
copyS.copy Destination:=Range("S" & internalS)
this will add in the lastrow +1 of my debit column
I have an excel file with lots of sheets named "xxA" and "xxB" with xx being consecutive numbers.
Each sheet has the following format:
header1 header2 header3 header 4 header5
ingredient1 description xx 20 g
ingredient2 description xx 34 ml
ingredient3 description xx 56 g
and some other rows at the end.
Basically I want to create a new sheet in which rows 2-27 from column D are copied to a column named "value" and create two new columns with the number in the sheet name and another one with the letter like so:
subject condition ingredient value
21 A ingredient1 20
21 A ingredient2 34
21 A ingredient3 56
21 B ingredient1 34
21 B ingredient2 23
21 B ingredient3 47
...
I tried messing with pivot tables but that doesn't really work. I don't know how to create a VBA, so any direction on that would be great if that is the only way to go.
I think this is what you are looking for. It copies data from worksheets and gets the sheet names split as asked. I have it hard coded to only work for double digit numbers and single letters. Do you have sheets that do not fit that form? If so, I can rework my code!
ORIGINAL:
Sub SheetSummary()
'Make new worksheet with required headers
ActiveWorkbook.Sheets.Add
ActiveSheet.name = "Summary"
range("A1").Value = "subject"
range("B1").Value = "condition"
range("C1").Value = "ingredient"
range("D1").Value = "value"
Dim ws As Worksheet
Dim wsNum As String
Dim wsLetter As String
Dim wsLastRow As Long
Dim sumLastRow As Long
Dim myCell As range
Dim nextOpenRow As Long
'If a worksheet is not the summary, then get the data
For Each ws In Worksheets
If ws.name <> "Summary" Then
wsNum = Left(ws.name, 2)
wsLetter = Right(ws.name, 1)
wsLastRow = ws.Cells(Rows.count, "A").End(xlUp).Row
nextOpenRow = Cells(Rows.count, "A").End(xlUp).Row + 1
ws.range("A2", ws.Cells(wsLastRow, "A")).Copy
range("C" & nextOpenRow).PasteSpecial xlPasteAll
lastRow = Cells(Rows.count, "C").End(xlUp).Row
ws.range("C2", ws.Cells(wsLastRow, "C")).Copy
range("D" & nextOpenRow).PasteSpecial xlPasteAll
Application.CutCopyMode = False
For Each myCell In range("A2", Cells(lastRow, "A"))
If myCell.Value = "" Then
myCell.Value = wsNum
End If
Next myCell
For Each myCell In range("B2", Cells(lastRow, "B"))
If myCell.Value = "" Then
myCell.Value = wsLetter
End If
Next myCell
End If
Next ws
End Sub
EDIT:
Sub SheetSummary()
'Make new worksheet with required headers
ActiveWorkbook.Sheets.Add
ActiveSheet.name = "Summary"
range("A1").Value = "subject"
range("B1").Value = "condition"
range("C1").Value = "ingredient"
range("D1").Value = "value"
Dim ws As Worksheet
Dim wsNum As String
Dim wsLetter As String
Dim wsLastRow As Long
Dim sumLastRow As Long
Dim myCell As range
Dim nextOpenRow As Long
'If a worksheet is not the summary, then get the data
For Each ws In Worksheets
If ws.name <> "Summary" Then
wsNum = Left(ws.name, 2)
wsLetter = Right(ws.name, 1)
wsLastRow = ws.Cells(Rows.count, "A").End(xlUp).Row
nextOpenRow = Cells(Rows.count, "A").End(xlUp).Row + 1
ws.range("A2:A27").Copy
range("C" & nextOpenRow).PasteSpecial xlPasteAll
lastRow = Cells(Rows.count, "C").End(xlUp).Row
ws.range("D2:D27").Copy
range("D" & nextOpenRow).PasteSpecial xlPasteAll
Application.CutCopyMode = False
For Each myCell In range("A2", Cells(lastRow, "A"))
If myCell.Value = "" Then
myCell.Value = wsNum
End If
Next myCell
For Each myCell In range("B2", Cells(lastRow, "B"))
If myCell.Value = "" Then
myCell.Value = wsLetter
End If
Next myCell
End If
Next ws
End Sub
Since you don't know VBA I wouldn't recommend taking that route. You can acheive everything you want using Excel formulas.
To get the name of a sheet use:
=MID(CELL("filename",A1),FIND("]",CELL("filename",A1))+1,255)
Replace "A1" with a reference to the cell on the worksheet you want the name of.
Then use the Left() function to split out the "xx" from the name and then use the Right() function to split out "A"
Hope this helps.
I have found the code
Sub Test()
Application.ScreenUpdating = False
Dim LastRow As Long
LastRow = Cells.Find("*", SearchOrder:=xlByRows,SearchDirection:=xlPrevious).Row
Dim lColumn As Long
Dim x As Long
Dim rng As Range
For Each rng In Range("A1:A" & LastRow)
lColumn = Cells(rng.Row, Columns.Count).End(xlToLeft).Column
For x = 1 To lColumn - 2
Range(Cells(rng.Row, "A"), Cells(rng.Row, "B")).Copy Sheets("Sheet2").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
Sheets("Sheet2").Cells(Rows.Count, "C").End(xlUp).Offset(1, 0) = rng.Offset(0, x + 1)
Next x
Next rng
Application.ScreenUpdating = True
End Sub
I am trying to modify it to suit my needs but it isn't quite doing what I need it to do.
Basically, my table is like this:
A B C D
FILENAME ID FIELD1 FIELD2
1 2 3 4
and I want it to look like this:
A FILENAME 1
B ID 2
C FIELD1 3
D FIELD2 4
however, sometimes there may be more columns or rows associated with a given part of the range that is related to a set of data. right now the columns that
I don't know nearly enough about excel and vba to modify this code to do that, but it would be nice if I could.
below are a couple of links that explain closely how I want the final table to look.
http://pastebin.com/1i5MqTL7
http://imgur.com/a/PKAcy
The ID's are not unique product pointers, but that's the REAL world. Different considerations and assumptions about the consistency of your input data, but try this:
Private Sub TransposeBits()
Application.ScreenUpdating = False
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Sheet2")
'start will be the starting row of each set
Dim start As Long
start = 2
'finish will be the last row of each set
Dim finish As Long
finish = start
Dim lastRow As Long
lastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
'printRow will keep track of where to paste-transpose each set
Dim printRow As Long
printRow = lastRow + 2
'lastCol will measure the column count of each set
Dim lastCol As Long
'Just dealing with a single entry here - delete as necessary
If lastRow < 3 Then
lastCol = Cells(start, 1).End(xlToRight).Column
With ws
.Range(.Cells(start, 1), .Cells(finish, lastCol)).Copy
.Cells(printRow, 1).PasteSpecial Transpose:=True
End With
Application.ScreenUpdating = True
'in the trivial case, we can exit the sub after dealing with the one-line transpose
Exit Sub
End If
'more general case
For i = 3 To lastRow
If Not Range("A" & i).Value = Range("A" & i - 1).Value Then
'the value is different than above, so set the finish to the above row
finish = i - 1
lastCol = Cells(start, 1).End(xlToRight).Column
'copy the range from start row to finish row and paste-transpose
With ws
.Range(.Cells(start, 1), .Cells(finish, lastCol)).Copy
.Cells(printRow, 1).PasteSpecial Transpose:=True
End With
'after finding the end of a set, reset the start and printRow variable
start = i
printRow = printRow + lastCol
End If
Next i
'here we deal with the last set after running through the loop
finish = lastRow
lastCol = Cells(start, 1).End(xlToRight).Column
With ws
.Range(.Cells(start, 1), .Cells(finish, lastCol)).Copy
.Cells(printRow, 1).PasteSpecial Transpose:=True
End With
Application.ScreenUpdating = True
End Sub
You can use the Paste Special that #Jeeped uses - just write it in code:
Sub TransposeData()
Dim rLastCell As Range
With ThisWorkbook.Worksheets("Sheet1")
'NB: If the sheet is empty this will throw an error.
Set rLastCell = .Cells.Find("*", SearchDirection:=xlPrevious)
'Copy everything from A1 to the last cell.
.Range(.Cells(1, 1), rLastCell).Copy
'Paste/Transpose in column A, one row below last row containing data.
.Cells(rLastCell.Row + 1, 1).PasteSpecial Transpose:=True
End With
End Sub