I am having problem with the following code.
I am trying to copy some data (as values) from one sheet to another (the data in the original sheet ("DAX NE3") is retrieved from a DAX database and the number of rows may vary depending on the date etc., so it has to copy all rows in every case). I have to take the two first columns (A and B) in "DAX NE3" and copy into column A and B in "Sheet4", but column C-F in "DAX NE3" has to be copied to column D-G in "Sheet4". All blank cells in the original data has to be equal to '0'. Furthermore I need to make a 'Share of part' in column C in 'Sheet4', so example C6=B6/sum(all B) and so on.
My Data when copying and pasting is all over the place. Can someone see why and please help?
Sub CopyData()
Dim m As Long
Dim rng As Range
Dim result As Variant
Dim firstvalue As Variant
Dim secondvalue As Variant
'Delete old data
Worksheets("Sheet4").Rows("6:" & Rows.Count).ClearContents
'Copy data from one sheet to another
On Error Resume Next
m = Worksheets("DAX NE3").Range("A:B").Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
If Err Then
MsgBox "No data to copy!", vbExclamation
Exit Sub
End If
On Error GoTo 0
Worksheets("DAX NE3").Range("A27:C" & m).Copy
Worksheets("Sheet4").Range("A6:C" & m + 1).Insert Shift:=xlShiftDown
Worksheets("Sheet4").Range("A6:C" & m + 1).PasteSpecial Paste:=xlPasteValues
Worksheets("DAX NE3").Range("A1").Copy Destination:=Worksheets("Sheet4").Range("A6").Resize(m)
Application.CutCopyMode = False
On Error Resume Next
m = Worksheets("DAX NE3").Range("B:F").Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
If Err Then
MsgBox "No data to copy!", vbExclamation
Exit Sub
End If
On Error GoTo 0
Worksheets("DAX NE3").Range("B27:G" & m).Copy
Worksheets("Sheet4").Range("C6:G" & m + 1).Insert Shift:=xlShiftDown
Worksheets("Sheet4").Range("C6:G" & m + 1).PasteSpecial Paste:=xlPasteValues
Worksheets("DAX NE3").Range("C1").Copy Destination:=Worksheets("Sheet4").Range("C6").Resize(m)
Application.CutCopyMode = False
'Change all Blank cells to '0'
Set rng = Sheets("Sheet4").Range("B6:B" & m)
Sheets("Sheet4").Activate
rng.Select
Selection.Replace What:="", Replacement:="0", LookAt:=xlWhole, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
'Calculate Share of portfolio %
firstvalue = Range("B6").Value
secondvalue = Range("B6" & Cells(Rows.Count, 2).End(xlUp).Row).Value > 0
m = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Worksheets("Sheet4").Range("C6:C" & m).Formula = firstvalue / secondvalue
End Sub
Related
Trying to copy data from one Excel spreadsheet to another (from New_data to report).
In the New_data spreadsheet I find the second time System (hence why I start the search below the first one at N21) appears then I need to copy all data below it from columns b - k until I hit blank cells. How do I get the amount of rows to only capture filled cells?
Range("B584:K641") needs to be dynamic.
Sub CopyWorkbook()
Range("N21").Select
Cells.Find(What:="system", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False).Activate
Range("B584:K641").Select
Selection.Copy
Application.WindowState = xlNormal
Windows("report.xlsx").Activate
Range("A2").Select
ActiveSheet.Paste
Windows("new_data.csv"). _
Activate
End Sub
Try the next code please. It should be very fast (if I correctly understood where to be searched for 'system', starting with what...). The code assumes that "new_data.csv" is the csv workbook name. If not, you must use its real name when defining shCSV sheet:
Sub CopyWorkbook()
Dim shR As Worksheet, shCSV As Worksheet, lastRow As Long, systCell As Range, arr
Set shR = Workbooks("report.xlsx").ActiveSheet 'use here the sheet you need to paste
'it should be better to use the sheet name.
'No need to have the respective sheet activated at the beginning
Set shCSV = Workbooks("new_data.csv").Sheets(1) 'csv file has a single sheet, anyhow
lastRow = shCSV.Range("B" & rows.count).End(xlUp).row
Set systCell = shCSV.Range("B21:B" & lastRow).Find(What:="system", _
After:=shCSV.Range("B21"), LookIn:=xlFormulas, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False)
If systCell Is Nothing Then MsgBox "No 'sytem' cell has been found...": Exit Sub
arr = shCSV.Range(systCell, shCSV.Range("K" & lastRow)).Value
shR.Range("A2").Resize(UBound(arr), UBound(arr, 2)).Value = arr
End Sub
Try:
Sub test()
Dim LR As Long
Dim Ini As Long
LR = Range("B" & Rows.Count).End(xlUp).Row 'last non empty row in column B
Ini = Application.WorksheetFunction.Match("system", Range("N21:N" & LR), 0) + 20 'position of system after n21
Range("B" & Ini & ":K" & LR).Copy
'''rest of your code to paste
End Sub
Note that this code is searching word system only in column N. If it's somewhere else, you'll need to adapt the MATCH function
I set a range to equal the filtered range and start a loop to count how many none empty cells occur until the first empty cell in column B.
Sub CopyWorkbook()
ThisWorkbook.Sheets("new_data").Activate
Range("N21").Select
Dim rng As Range
Set rng = Cells.Find(What:="system", After:=ActiveCell, _
LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, _
SearchFormat:=False)
Dim i As Double
i = rng.Row
Do Until ThisWorkbook.Sheets("new_data").Range("B" & i) = vbNullString
i = i + 1
Loop
i = i - 1
Range("B" & rng.Row & ":K" & i).Select
Selection.Copy
Application.WindowState = xlNormal
Windows("report.xlsx").Activate
Range("A2").Select
ActiveSheet.Paste
Windows("new_data.csv").Activate
End Sub
I found a Stack Overflow question that was helpful in finding an answer. Find cell address
I have a excel sheet with around 50k rows and i need a macro to search for a cell in that sheet and if it finds it to copy the entire row to another sheet, my problem is that the keyword may be on multiple rows so if there are like 4 cells with that keyword i need it to copy all 4 rows and paste them in another sheet
Dim intPasteRow As Integer
intPasteRow = 2
Sheets("Sheet2").Select
Columns("A:AV").Select
On Error Resume Next
Selection.Find(What:="m12", After:=ActiveCell, LookIn:= _
xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:= _
xlNext, MatchCase:=True, SearchFormat:=True).Activate
If Err.Number = 91 Then
MsgBox "ERROR: 'Keyword' could not be found."
Sheets("Sheet1").Select
End
End If
Dim intRow As Integer
intRow = ActiveCell.Row
Rows(intRow & ":" & intRow).Select
Selection.Copy
Sheets("Sheet1").Select
ActiveSheet.Paste
End Sub
Sub saci()
Dim rng As Range
Set rng = Range(ActiveCell, ActiveCell.Offset(10000, 0))
rng.EntireRow.Select
With Selection.EntireRow
.Cut
.Offset(.Rows.Count + 1).Insert
.Select
End With
Range("A4").Select
End Sub
so far its finding the first "m12" cell in Sheet2 and copies the entire row to Sheet1, how do i make it continue to search after finding "m12" and copy all rows with the "m12" in them instead of just the first one?
i have a code that copies an array of values from 1 sheet and pastes it in another now i want to offst the last populated row by 1 and delete the original row ie if the last row were L12:(entire row) it is pasted to L13 and row L12 is left empty.
Dim ws As Worksheet
Set ws = Worksheets("Pivot_WH calculations") 'change name as needed
With ws
'assumes data is in a "table" format with all data rows in column A and data columns in row 1
.Range("E2:J7").Copy _
Worksheets("WH Calc_new").Range("L" & .Rows.Count).End(xlUp).Offset(2)
.Range("E8:J8").Copy _
Worksheets("WH Calc_new").Range("L" & .Rows.Count).End(xlUp).Offset(2)
.Range("A2:A9").Copy _
Worksheets("WH Calc_new").Range("K" & .Rows.Count).End(xlUp).Offset(2)
End With
End Sub
The Function at the End will give you the last Row That is actually the last row used in the Worksheet.
For the offset you can change 2 to 3 or 4 or any other number you want to Offset in .Offset(Number_Here)
Try This:
Sub cdd()
Dim ws As Worksheet
Dim lst As Long
Set ws = Worksheets("Pivot_WH calculations") 'change name as needed
lst = LastRow(Worksheets("WH Calc_new"))
With ws
.Range("E2:J7").Copy Worksheets("WH Calc_new").Range("L" & lst).Offset(2)
.Range("E8:J8").Copy Worksheets("WH Calc_new").Range("L" & lst).Offset(2)
.Range("A2:A9").Copy Worksheets("WH Calc_new").Range("K" & lst).Offset(2)
End With
End Sub
Function LastRow(Sh As Worksheet)
On Error Resume Next
LastRow = Sh.Cells.Find(What:="*", _
After:=Sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).row
On Error GoTo 0
End Function
I have a question related to the VBA.
Problem
I have a code to do simple task but i don't what's the reason but sometimes this code works perfectly some time it's not.
Code Explanation
Go to active sheets(un-hidden) sheets in the work book.
Search specific text in the assign column, in this case text is "Sum of Current Activity".
Copy the cell before the text.
Go to Reviewer sheet and find sheet name in the table.
Paste the copied cell as link value next to cell where we have sheet name in the table.
Continue the same process until all active sheets searched
CODE
Sub Sum of_Current_activity()
Dim sht As Worksheet
Sheets("Reviewer Sheet").Select
For Each sht In ActiveWorkbook.Worksheets
If sht.Name <> "Reviewer Sheet" And Left(sht.Name, 1) = 0 Then
On Error Resume Next
sht.Select
f2 = " Total"
£1 = ActiveSheet.Name & f2
Sheets(sht).Select
Columns("J:J").Select
Selection.Find(What:="Sum of Current Activity", _
After:=ActiveCell,_
LookIn:=xlValues,_
LookAt:=xlPart,_
SearchOrder:=xlByRows,_
SearchDirection:=x1Next,_
MatchCase:=False).Activate
ActiveCell.Offset(0, 1).Select
Selection.Copy
Sheets("Reviewer Sheet").Select
Columns("C:C").Select
Selection.Find(What:=f1, _
After:=ActiveCell,_
LookIn:=xlValues,_
LookAt:=xlPart,_
SearchOrder:=xlByRows,_
SearchDirection:=xlNext,_
MatchCase:=False).Activate
ActiveCell.Offset(0, 14).Select
ActiveSheet. Paste Link:=True
Else
End If
Next sht
End Sub
P.S, I have 10 different specific text to search in the 25 sheet. this code sometime works for all 10 texts and sometimes miss the values.
Untested but something like this should work:
Sub Sum of_Current_activity()
Dim sht As Worksheet, c1 As Range, c2 As range
For Each sht In ActiveWorkbook.Worksheets
If sht.Name Like "0*" Then
Set c1 = sht.Columns("J:J").Find(What:="Sum of Current Activity", _
LookIn:=xlValues, LookAt:=xlPart, MatchCase:=False)
Set c2 = Sheets("Reviewer Sheet").Columns("C:C").Find( _
What:= sht.Name & " Total", _
LookIn:=xlValues, LookAt:=xlPart, MatchCase:=False)
If not c1 is nothing and not c2 is nothing then
'edit: create link instead of copy value
c2.offset(0, 14).Formula = _
"='" & c1.parent.Name & "'!" & c1.offset(0,1).Address(true, true)
End if
End If
Next sht
End Sub
just because the task is simple, you could use On Error Resume Next statement and make a direct Value paste between ranges:
Sub main()
Dim sht As Worksheet
On Error Resume Next ' prevent any subsequent 'Find()' method failure fro stopping the code
For Each sht In Worksheets
If Left(sht.Name, 1) = "0" Then _
Sheets("Reviewer Sheet").Columns("C:C").Find( _
What:=sht.Name & " Total", _
LookIn:=xlValues, LookAt:=xlPart, MatchCase:=False).Offset(0, 14).Value = sht.Columns("J:J").Find(What:="Sum of Current Activity", _
LookIn:=xlValues, LookAt:=xlPart, MatchCase:=False).Offset(0, 1).Value
Next
End Sub
I once more stress that On Error Resume Next is here used only because it's a case where you can have a full control of its side effects that can arise from ignoring errors and go on
should you use this snippet in a bigger code, than close the snippet with On Error GoTo 0 statement and resume default error handling before going on with some other code.
With th following Excel Sheet.
I'm trying to do the following:
Find the cell with Value, let's say "Sam", in range("B17:B25")
Offset(0,5).resize(,8).copy
Find the Date value of the Data row, and paste Data to range("B4:M4") according to the data's Date.
Loop to find next.
Here is what I got so far, don't know how to loop:
Sub getDat()
Dim myFind As Range
Dim pasteLoc As Range
Dim payee, pasteMon As String
Range("B5:M12").ClearContents
With Sheet3.Cells
payee = Range("B2").Text
Set myFind = .Find(What:=payee, After:=Range("B16"), LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=True, SearchFormat:=False)
If Not myFind Is Nothing Then
myFind.Offset(0, 3).Resize(, 8).Copy
pasteMon = myFind.Offset(0, 1).Text
With Range("B4:M4")
Set pasteLoc = .Find(What:=pasteMon, LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=True, SearchFormat:=False)
If Not pasteLoc Is Nothing Then
pasteLoc.Offset(1, 0).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=True
End If
End With
End If
End With
End Sub
Here is simplified version (not tested)
Sub getDat()
Range("B5:M12").ClearContents
Dim c As Range, r As Range
For Each c in Range("B16").CurrentRegion.Columns(1).Cells
If c = Range("B2") Then
Set r = Range("B4:M4").Find(c(, 2))
If Not r Is Nothing Then
r(2).Resize(8) = Application.Transpose(c(, 4).Resize(, 8))
End If
End If
Next
End Sub
Something like this For loop would work as well:
Sub getDat()
Dim payee As String
Dim lastrow As Long
lastrow = Cells(Rows.Count, "B").End(xlUp).Row
payee = Range("B2").Value
Range("B5:M12").ClearContents
For x = 17 To lastrow
If Cells(x, 2).Value = payee Then
For y = 2 To 13
If Cells(4, y).Value = Cells(x, 3).Value Then
Range("E" & x & ":L" & x).Copy
ActiveSheet.Range(Cells(5, y), Cells(12, y)).PasteSpecial Transpose:=True
Exit For
End If
Next y
End If
Next x
End Sub