I am using below vba code to copy a cell value from one sheet to another. The value will always be a number. I have formatted both source and target cells as a number. But whenever vba runs, I am getting message " Number stored as text" even though there is no change in cell format.
How can I resolve this?
VBA Code:
Private Sub Worksheet_Calculate()
Application.ScreenUpdating = False
Dim ws As Worksheet
Set mw = Workbooks("StockScreen.xlsm").Sheets("MW")
Set ws = Workbooks("StockScreen.xlsm").Sheets("TimeStampWork")
If Value <> mw.Range("A2").Value Then
Range("A2,E2").Copy
ws.Range("B" & ws.Cells(ws.Rows.Count, "B").End(xlUp).Row + 1).PasteSpecial xlPasteValues
Dim Max
Dim Min
Max = Application.WorksheetFunction.Max(ws.Range("b:b"))
Min = Application.WorksheetFunction.Min(ws.Range("b:b"))
Sheets("TimeStampWork").Range("F2") = Max
Sheets("TimeStampWork").Range("G2") = Min
End If
End Sub
May be instead of
Range("A2,E2").Copy
ws.Range("B" & ws.Cells(ws.Rows.Count, "B").End(xlUp).Row + 1).PasteSpecial xlPasteValues
try
Range("A2,E2").Copy
With ws.Range("B" & ws.Cells(ws.Rows.Count, "B").End(xlUp).Row + 1)
.PasteSpecial xlPasteValues, , False, False
.PasteSpecial xlPasteFormats, , False, False
End With
Related
I'm running into an issue where I'm unable to copy only visible cells to a new sheet. I'm able to get the lastrow, but I get #N/A on every cell except the first for each column. I want to just copy the visible cells. I'd also like to only put information on visible rows too, if possible?
Please see my code below:
Sub Importe()
lastRow = Worksheets("Sheet1").Cells(1, 1).SpecialCells(xlCellTypeVisible).End(xlDown).Row
Worksheets.Add
With ActiveSheet
Range("A1:A" & lastRow).Value2 = _
ActiveWorkbook.Worksheets("Sheet1").Range("H1:H" & lastRow).SpecialCells(xlCellTypeVisible).Value
Range("B1:B" & lastRow).Value2 = _
ActiveWorkbook.Worksheets("Sheet1").Range("E1:E" & lastRow).SpecialCells(xlCellTypeVisible).Value
End With
End Sub
Something like .Value2 = .Value doesn't work on special cells of type visible, because …
… e.g. if lastRow = 50 and there are hiddenRows = 10 then …
your source Range("H1:H" & lastRow).SpecialCells(xlCellTypeVisible)
has lastRow - hiddenRows = 40 rows
but your destination Range("A1:A" & lastRow).Value2
has lastRow = 50 rows.
On the first you subtract the visible rows, so they are different in size. Therefore .Value2 = .Value doesn't work, because you cannot fill 50 rows with only 40 source rows.
But what you can do is Copy and SpecialPaste
Option Explicit
Sub Importe()
Dim lastRow As Long
lastRow = Worksheets("Sheet1").Cells(1, 1).SpecialCells(xlCellTypeVisible).End(xlDown).Row
Worksheets.Add
With ActiveSheet
ActiveWorkbook.Worksheets("Sheet1").Range("H1:H" & lastRow).SpecialCells(xlCellTypeVisible).Copy
.Range("A1").PasteSpecial xlPasteValues
ActiveWorkbook.Worksheets("Sheet1").Range("E1:E" & lastRow).SpecialCells(xlCellTypeVisible).Copy
.Range("B1").PasteSpecial xlPasteValues
End With
End Sub
Nevertheless I recommend to avoid ActiveSheet or ActiveWorkbook if this is possible and reference a workbook eg by ThisWorkbook. My suggestion:
Option Explicit
Sub Importe()
Dim SourceWs As Worksheet
Set SourceWs = ThisWorkbook.Worksheets("Sheet1")
Dim DestinationWs As Worksheet
Set DestinationWs = ThisWorkbook.Worksheets.Add
Dim lastRow As Long
lastRow = SourceWs.Cells(1, 1).SpecialCells(xlCellTypeVisible).End(xlDown).Row
SourceWs.Range("H1:H" & lastRow).SpecialCells(xlCellTypeVisible).Copy
DestinationWs.Range("A1").PasteSpecial xlPasteValues
SourceWs.Range("E1:E" & lastRow).SpecialCells(xlCellTypeVisible).Copy
DestinationWs.Range("B1").PasteSpecial xlPasteValues
End Sub
To define whether a cell is visible or not, both its column and row should be visible. This means, that the .Hidden property of the column and the row should be set to False.
Here is some sample code of how to copy only the visible ranges between two worksheets.
Imagine that you have an input like this in Worksheets(1):
Then you manually hide column B and you want to get in Worksheets(2) every cell from the Range(A1:C4), without the ones in column B. Like this:
To do this, you should check each cell in the range, whether its column or row is visible or not.
A possible solution is this one:
Sub TestMe()
Dim myCell As Range
For Each myCell In Worksheets(1).Range("A1:C4")
If (Not Rows(myCell.Row).Hidden) And (Not Columns(myCell.Column).Hidden) Then
Dim newCell As Range
Set newCell = Worksheets(2).Cells(myCell.Row, myCell.Column)
newCell.Value2 = myCell.Value2
End If
Next myCell
End Sub
Just a general advise - whenever you use something like this Range("A1").Value2 = Range("A1").Value2 make sure that both are the same and not the left is Value2 and the right is .Value. It probably will not bring what you are expecting.
You cannot perform a direct value transfer without cycling though the areas of the SpecialCells(xlCellTypeVisible) collection.
Sometimes it is easier to copy everything and get rid of what you don't want.
Sub Importe()
Dim lr As Long
Worksheets("Sheet1").Copy after:=Worksheets("Sheet1")
With ActiveSheet
.Name = "xyz"
.Cells(1, 1).CurrentRegion = .Cells(1, 1).CurrentRegion.Value2
For lr = .Cells(.Rows.Count, "A").End(xlUp).Row To 1 Step -1
If .Cells(lr, "A").EntireRow.Hidden Then
.Cells(lr, "A").EntireRow.Delete
End If
Next lr
lr = .Cells(.Rows.Count, "A").End(xlUp).Row
.Cells(1, 1).CurrentRegion.Resize(lr, 1) = .Cells(1, 1).CurrentRegion.Resize(lr, 1).Offset(0, 7).Value2
.Cells(1, 1).CurrentRegion.Offset(0, 1).Resize(lr, 1) = .Cells(1, 1).CurrentRegion.Resize(lr, 1).Offset(0, 4).Value2
.Columns("C:XFD").EntireColumn.Delete
End With
End Sub
just to throw in an alternative version:
Sub Importe()
Dim sht1Rng As Range, sht1VisibleRng As Range
With Worksheets("Sheet1")
Set sht1Rng = .Range("A1", .Cells(.Rows.Count, 1).End(xlUp))
End With
Set sht1VisibleRng = sht1Rng.SpecialCells(xlCellTypeVisible)
With Worksheets.Add
.Range("A1").Resize(sht1Rng.Rows.Count).Value2 = sht1Rng.Offset(, 7).Value2
.Range("B1").Resize(sht1Rng.Rows.Count).Value2 = sht1Rng.Offset(, 4).Value2
.UsedRange.EntireRow.Hidden = True
.Range(sht1VisibleRng.Address(False, False)).EntireRow.Hidden = False
End With
End Sub
which may have the drawback of Address() maximum "capacity "
I'm trying to add a vba code that looks in a column on sheet YTDFigures and sees if there is a duplicate in sheet EeeDetails. If there isn't then I want to copy the YTDFigures data and paste in a new sheet.
The code I've tried gets an error run time error 91 on the line FinName = Worksheets("EeeDetails").Range("A:A").Find(What:=SearchName, LookIn:=xlValues) I thought this would work as if a match isn't found the .Find function returns nothing.
Sub CheckMatch()
Application.ScreenUpdating = False
Dim SearchName As Range, SearchNames As Range
Dim Usdrws As Long
Dim row As Integer
Usdrws = Worksheets("YTDFigures").Range("A" & Rows.Count).End(xlUp).row
Set SearchNames = Worksheets("YTDFigures").Range("A2:A" & Usdrws)
For Each SearchName In SearchNames
row = Split(SearchName.Address, "$")(2)
FinName = Worksheets("EeeDetails").Range("A:A").Find(What:=SearchName, LookIn:=xlValues)
If FinName Is Nothing Then
Range("A" & row & ":S" & row).Copy
LastRow = Worksheets("Errors").Range("AA" & Rows.Count).End(xlUp).row + 1
Worksheets("Errors").Activate
Range("A" & LastRow).Select
Selection.PasteSpecial
Worksheets("EeeDetails").Activate
End If
Next
Application.ScreenUpdating = True
End Sub
You can place the raw data into an array, place the array on a temporary sheet, remove the duplicates, copy the data, then delete the temp sheet.
See below:
Sub CheckMatch()
Application.ScreenUpdating = False
Dim ws As Worksheet, tRows As Long
Set ws = ThisWorkbook.Worksheets(1)
Set RngA = ws.UsedRange.Columns("A")
tRows = ws.Rows(ws.Rows.Count).End(xlUp).row
Dim valA As Variant
valA = ws.Range(ws.Cells(1, 1), ws.Cells(tRows, 1)).Value
Dim tempWs As Worksheet
Set tempWs = ThisWorkbook.Worksheets.Add
tempWs.Name = "Temp1"
With tempWs
.Range(.Cells(1, 1), .Cells(tRows, 1)) = valA
With .UsedRange.Columns("A")
.RemoveDuplicates Columns:=1, Header:=xlYes
.Copy
End With
End With
' Do what you need to do with your copied data
Application.DisplayAlerts = False
tempWs.Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Edit:
I just tested this with sample data of over 10k rows, and it works in less than a half a second. It's very fast.
How do i get Auto-fill to automatically detect the next new ID# to duplicate in the following line without having to tell/ set the excel range where the next ID# would start?
Below is the formula.
Sub NewTestRow()
Application.ScreenUpdating = False
Dim copySheet As Worksheet
Dim pasteSheet As Worksheet
Dim LRow As Long
Set copySheet = Worksheets("Sheet1")
Set pasteSheet = Worksheets("Sheet2")
copySheet.Range("E3:K500").Copy
pasteSheet.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
Application.CutCopyMode = False
Application.ScreenUpdating = True
LRow = ActiveSheet.Cells(Sheets("Sheet2").Rows.Count, "A").End(xlUp).Row
Cells(2, 1).Select
Selection.Copy
ActiveSheet.Range(Cells(3, 1), Cells(LRow, 1)).Select
ActiveSheet.Paste
copySheet.Range("M3:S500").Copy
pasteSheet.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
[EXAMPLE FORMAT IMAGE]
This code cycles through cells in the first column, and checks that it is the same as the proceeding cell in the first column. Also, I'd change "LRow =" to a better way of finding the last row, just in case there are any gaps in your data.
LRow = ActiveSheet.Cells(Sheets("Sheet2").Rows.Count, "A").End(xlUp).Row
i = 2
' --- low
While i < LRow
If ActiveSheet.Cells(i, 1) = ActiveSheet.Cells(i + 1, 1) Then
' --- new ID not found, increment to next row
i = i + 1
ElseIf
' --- Put whatever code you want to fire when a new ID is found
NewIDFound = i + 1
End If
Wend
I need to copy values only without Formula from sheet to another. The following code does copy but only with Formula. I tried some solutions presented in this site but they give me errors.
For i = 2 To LastRow
'sheet to copy from
With Worksheets("Hoist")
'check column H value before copying
If .Cells(i, 8).Value >= -90 _
And CStr(.Cells(i, 9).Value) <> "Approved" _
And CStr(.Cells(i, 9).Value) <> "" _
And CStr(.Cells(i, 10).Value) = "" Then
'copy row to "display" sheet
.Rows(i).Copy Destination:=Worksheets("display").Range("A" & j)
j = j + 1
End If
End With
Next i
Try changing this line:
.Rows(i).Copy Destination:=Worksheets("display").Range("A" & j)
to this:
.Rows(i).Copy
Worksheets("display").Range("A" & j).PasteSpecial xlPasteValues
This however drops all formatting. To include formatting, you'll need to add another line like:
Worksheets("display").Range("A" & j).PasteSpecial xlPasteFormats
Another option is to enter a working column and use AutoFilter to avoid loops
insert a column in column A
the working column formuka is =AND(I2>-90,AND(J2<>"",J2<>"Approved"),K2="")
filter and copy the TRUE rows
delete working column A
code
Sub Recut()
Dim ws As Worksheet
Dim rng1 As Range
Set ws = Sheets("Hoist")
ws.AutoFilterMode = False
Set rng1 = Range([h2], Cells(Rows.Count, "H").End(xlUp))
ws.Columns(1).Columns.Insert
rng1.Offset(0, -8).FormulaR1C1 = "=AND(RC[8]>-90,AND(RC[9]<>"""",RC[9]<>""Approved""),RC[10]="""")"
With rng1.Offset(-1, -8).Resize(rng1.Rows.Count + 1, 1).EntireRow
.AutoFilter Field:=1, Criteria1:="TRUE"
.Copy Sheets("display").Range("A1")
Sheets("display").Columns("A").Delete
End With
ws.Columns(1).Delete
ws.AutoFilterMode = False
End Sub
This is a separate question stemming from this post: How to use the filename of an excel file to change a column of cells?
I noticed that in the last post's code it was referencing specific cells (J2,K2). However when using the code, I came into an error when the columns changed. So now I am seeking a way to modify the below code to use the names of the header columns to populate the 2nd column instead of referencing specific cells. I think the only line that really needs adjusting is the myRng line, but I will provide all the code I am trying for reference.
In case you don't read the other post, I will describe the issue. I am trying to fill in the 2nd column (name+type) based on the "name" column and the filename. When I was referencing the K or J row in the code, everything was working fine, but when I load a different file and the columns positions have changed, everything gets messed up.
I need to populate the 2nd column (name+type) to be the exactly the same number or rows as the 1st column (name) which is why I am using the Range ("K2:K" & lastCell) formula.
Is there a way to do this?
Current Attempted VBA code:
' Insert Column after name and then rename it name+type
Rows(1).Find("name").Offset(0, 1).EntireColumn.Insert
Rows(1).Find("name").Offset(0, 1).FormulaR1C1 = "name+type"
Dim myRng As Range
Dim lastCell As Long
Dim myOtherRange As Range
Dim column2Range As Range
myOtherRange = Rows(1).Find("name")
column2Range = Rows(1).Find("name+type")
lastCell = Range(myOtherRange).End(xlDown).Row
Set myRng = Range("K2:K" & lastCell)
myOtherRange.FormulaR2C1 = "=LEFT(MID(CELL(""filename""),SEARCH(""["",CELL(""filename""))+1, SEARCH(""]"",CELL(""filename""))-SEARCH(""["",CELL(""filename""))-1),5)&RC[-1]"
myOtherRange.FormulaR2C1.Select
Selection.Copy
myRng.Select
ActiveSheet.Paste
First Draft VBA code:
' Insert Column after name and then rename it name+type
Rows(1).Find("name").Offset(0, 1).EntireColumn.Insert
Rows(1).Find("name").Offset(0, 1).FormulaR1C1 = "name+type"
'Add the contents to the name+type column
Range("K2").Select
ActiveCell.FormulaR1C1 = "=LEFT(MID(CELL(""filename"",RC[-1]),SEARCH(""["",CELL(""filename"",RC[-1]))+1,SEARCH(""]"",CELL(""filename"",RC[-1]))-SEARCH(""["",CELL(""filename"",RC[-1]))-1),5)&RC[-1]"
Range("K2").Select
Selection.Copy
Range("K2:K8294").Select
ActiveSheet.Paste
#Scott or Siddharth Rout probably =) – Jonny 11 hours ago
I would never recommend this :) SO is full of experts who can assist you. Why do you want to limit the help that you can get? ;)
Is this what you are trying?
Option Explicit
Sub Sample()
Dim ws As Worksheet
Dim lRow As Long, aCol As Long
Dim aCell As Range
Set ws = Sheets("Sheet1") '<~~ Change this to the relevant sheet name
With ws
Set aCell = .Rows(1).Find("Name")
'~~> Check if the column with "name" is found
If Not aCell Is Nothing Then
aCol = aCell.Column
.Columns(aCol + 1).EntireColumn.Insert
.Cells(1, aCol + 1).Value = "Name+Type"
.Activate
.Rows(1).Select
With ActiveWindow
.SplitColumn = 0
.SplitRow = 1
.FreezePanes = True
End With
'~~> Get lastrow of Col which has "name"
lRow = .Range(Split(.Cells(, aCol).Address, "$")(1) & .Rows.Count).End(xlUp).Row
ThisWorkbook.Save
'~~> Add the formula to all the cells in 1 go.
.Range(Split(.Cells(, aCol + 1).Address, "$")(1) & "2:" & _
Split(.Cells(, aCol + 1).Address, "$")(1) & lRow).Formula = _
"=LEFT(MID(CELL(""filename"",RC[-1]),SEARCH(""["",CELL(""filename"",RC[-1]))+1," & _
"SEARCH(""]"",CELL(""filename"",RC[-1]))-SEARCH(""["",CELL(""filename"",RC[-1]))-1),5)&RC[-1]"
.Columns("A:AK").Columns.AutoFit
Else
MsgBox "Name Column Not Found"
End If
End With
End Sub
After modifying the code provided by Siddharth, this is the final code that worked for me. The save feature needed to also remove a format and the Formula to search and add the filename to the cells did not work without this edit. I also had to change the sheet to the activeSheet, because it was constantly changing. Here is the code:
Sub Naming()
Dim LR As Long, i As Long, lngCol As Long
lngCol = Rows(1).Find("NAME", lookat:=xlWhole).Column 'assumes there will always be a column with "NAME" in row 1
Application.ScreenUpdating = False
LR = Cells(Rows.Count, lngCol).End(xlUp).Row
For i = LR To 1 Step -1
If Len(Cells(i, lngCol).Value) < 4 Then Rows(i).Delete
Next i
Application.ScreenUpdating = True
' Insert Column after NAME and then rename it NAME+TYPE
Dim ws As Worksheet
Dim lRow As Long, aCol As Long
Dim aCell As Range
Set ws = ActiveSheet 'Need to change to the Active sheet
With ws
Set aCell = .Rows(1).Find("NAME")
' Check if the column with "NAME" is found, it is assumed earlier
If Not aCell Is Nothing Then
aCol = aCell.Column
.Columns(aCol + 1).EntireColumn.Insert
.Cells(1, aCol + 1).Value = "NAME+TYPE"
.Activate
' Freeze the Top Row
Rows("1:1").Select
With ActiveWindow
.SplitColumn = 0
.SplitRow = 1
End With
ActiveWindow.FreezePanes = True
' Get lastrow of Col which has "NAME"
lRow = .Range(Split(.Cells(, aCol).Address, "$")(1) & .Rows.Count).End(xlUp).Row
'Save the file and format the filetype
Dim wkb As Workbook
Set wkb = ActiveWorkbook 'change to your workbook reference
wkb.SaveAs Replace(wkb.Name, "#csv.gz", ""), 52 'change "csv.gz" to ".xlsm" if need be
' Add the formula to all the cells in 1 go.
.Range(Split(.Cells(, aCol + 1).Address, "$")(1) & "2:" & _
Split(.Cells(, aCol + 1).Address, "$")(1) & lRow).Formula = _
"=LEFT(MID(CELL(""filename""),SEARCH(""["",CELL(""filename""))+1, SEARCH(""]"",CELL(""filename""))-SEARCH(""["",CELL(""filename""))-1),5)&RC[-1]"
.Columns("A:AK").Columns.AutoFit
Else
MsgBox "NAME Column Not Found"
End If
End With
' Change the Range of the cursor
Range("A1").Select
Application.CutCopyMode = False
End Sub