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
Related
VBA Creating new sheets from unique column values in Sheet1 + bringing over adjacent row information
Hey all- I'm trying to a script that identifies the unique values in column E (data starts on row 1), creates a new sheet based on those unique values (also names the sheet per the value), and in the new sheet it creates it brings over the information corresponding rows in column A, C, D, and H -
I found this YouTube video that shows the process but instead of the script indentifying the unique values you have to manually input the keyword it is looking for and it only runs it once. I haven't been able to get the 'for loop' to run properly ...
https://www.youtube.com/watch?v=qGZQIl9JJk4&t=561s
Any help would be much appreciated-!
Private Sub CommandButton1_Click()
J = "Test"
Worksheets.Add().Name = J
Worksheets("Sheet1").Rows(1).Copy
Worksheets(J).Activate
ActiveSheet.Paste
Worksheets("Sheet1").Activate
a = Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To a
If Worksheets("Sheet1").Cells(i, 5).Value = "XXXX" Then
Worksheets("Sheet1").Rows(i).Copy
Worksheets(J).Activate
b = Worksheets(J).Cells(Rows.Count, 1).End(xlUp).Row
Worksheets(J).Cells(b + 1, 1).Select
ActiveSheet.Paste
Worksheets("Sheet1").Activate
End If
Next
Application.CutCopyMode = False
ThisWorkbook.Worksheets("Sheet1").Cells(1, 1).Select
End Sub
Something like this:
Private Sub CommandButton1_Click()
Dim sht As Worksheet, c As Range, i As Long
Set sht = ThisWorkbook.Worksheets("Sheet1")
For i = 2 To sht.Cells(Rows.Count, 1).End(xlUp).Row
CopyDestination(sht.Cells(i, 5).Value).Resize(1, 5).Value = _
Array(sht.Cells(i, 5).Value, sht.Cells(i, 1).Value, _
sht.Cells(i, 3).Value, sht.Cells(i, 4).Value, _
sht.Cells(i, 8).Value)
Next
Application.CutCopyMode = False
End Sub
'Find the next "paste" destination on the appropriate sheet named "v"
' If sheet doesn't exist, create it
Function CopyDestination(v) As Range
Dim sht As Worksheet
On Error Resume Next
Set sht = ThisWorkbook.Sheets(v)
On Error GoTo 0
If sht Is Nothing Then '<< no existing matching sheet
With ThisWorkbook
Set sht = .Sheets.Add(after:=.Sheets(.Sheets.Count))
End With
sht.Name = v '<<< assumes "v" is valid as a worksheet name...
End If
'find the first empty cell in Col A
Set CopyDestination = sht.Cells(sht.Rows.Count, 1).End(xlUp).Offset(1, 0)
End Function
I am trying to transfer the data from sheet one to sheet two and combined the information on the second sheet. The code I have listed below works, but it seems very inefficient. I am trying to improve by VBA abilities and would love to here ways to shrink my code down, make it more efficient, and still achieve the same goal. Thanks for any help you can provide.
Sheet 1
Sheet 2
Sub batchorder()
Dim Pname As String
Dim Lplace As String
Dim numsld As Long
Dim rating As Integer
Dim lastrow As Long
Dim i As Long
Dim openc As Long
lastrow = Range("A" & Rows.Count).End(xlUp).Row
Range("A1").Select
For i = 1 To lastrow
If Cells(i, 1).Value <> "" Then
'Copy name to sheet 2
Cells(i, 1).Select
ActiveCell.Offset(0, 1).Select
Selection.Copy
Sheets("Sheet2").Select
Range("A1").Select
'Find the next open cell to paste to
Selection.End(xlDown).Select
Selection.End(xlDown).Select
Selection.End(xlUp).Select
ActiveCell.Offset(1, 0).Select
ActiveSheet.Paste
Sheets("Sheet1").Select
'Copy place to sheet 2
ActiveCell.Offset(1, 0).Select
Selection.Copy
Sheets("Sheet2").Select
Range("B1").Select
'Find the next open cell to paste to
Selection.End(xlDown).Select
Selection.End(xlDown).Select
Selection.End(xlUp).Select
ActiveCell.Offset(1, 0).Select
ActiveSheet.Paste
Sheets("Sheet1").Select
'Copy sold to sheet 2
ActiveCell.Offset(1, 0).Select
Selection.Copy
Sheets("Sheet2").Select
Range("C1").Select
'Find the next open cell to paste to
Selection.End(xlDown).Select
Selection.End(xlDown).Select
Selection.End(xlUp).Select
ActiveCell.Offset(1, 0).Select
ActiveSheet.Paste
Sheets("Sheet1").Select
'Copy rating to sheet 2
ActiveCell.Offset(1, 0).Select
Selection.Copy
Sheets("Sheet2").Select
Range("D1").Select
'Find the next open cell to paste to
Selection.End(xlDown).Select
Selection.End(xlDown).Select
Selection.End(xlUp).Select
ActiveCell.Offset(1, 0).Select
ActiveSheet.Paste
Sheets("Sheet1").Select
Sheets("Sheet1").Select
i = i + 3
Else
End If
Next i
End Sub
Sub batchorder()
Dim Row As Long
Dim i As Long
' These two lines speed up evrything ENORMOUSLY.
' But you need the lines at the end too
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Row = Sheet2.UsedRange.Rows.Count ' Row is nr of last row in sheet
While Application.CountA(Sheet2.Rows(Row)) = 0 And Row > 1
Row = Row - 1 ' skip empty rows at the end if present
Wend
For i = 1 To Sheet1.UsedRange.Rows.Count
If Sheet1.Cells(i, 1).Value <> "" Then
Sheet2.Cells(Row, 1).FormulaLocal = Sheet1.Cells(i, 2).FormulaLocal
Sheet2.Cells(Row, 2).FormulaLocal = Sheet1.Cells(i + 1, 2).FormulaLocal
Sheet2.Cells(Row, 3).FormulaLocal = Sheet1.Cells(i + 2, 2).FormulaLocal
Sheet2.Cells(Row, 4).FormulaLocal = Sheet1.Cells(i + 3, 2).FormulaLocal
i = i + 3
Row = Row + 1
End If
Next
' Restore Excel to human state.
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
You should basically never use the select statement, it gets everything really messy quickly. Here's a basic combiner of mine. Just added the If statement to check whether the cell and in this case row is empty.
This should work but more importantly try to understand what it does to learn. I gave it some comments.
Sub batchorder()
Dim ws1 As Worksheet
Dim ws2 As Worksheet
' Just habits, but doing this here means that I won't have to write anything else than ws1 and ws2 in the future
Set ws1 = Worksheets("Sheet1")
Set ws2 = Worksheets("Sheet2")
Dim lastrowWs1 As Long
Dim j As Long
' first row after ws2 headers
j = 2
' With statement to make the code nicer also ".something" now means ws1.something
With ws1
' Bob Ulmas method -- just a personal preference to find the last row.
lastrowWs1 = .Cells.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row
For i = 1 To lastrowWs1
' Check if the cell is not empty
If Not .Cells(i, 1) = vbNullString Then
'Basically range.value = other_range.value
ws2.Range(ws2.Cells(j, 1), ws2.Cells(j, 4)).Value = WorksheetFunction.Transpose(.Range(.Cells(i, 2), .Cells(i + 3, 2)).Value)
' step 3 forward as the amount of rows per record was 4
i = i + 3
' go to next row for worksheet 2
j = j + 1
End If
Next i
End With
End Sub
I have a macro which copy paste my data in another sheet when I press the button, but it also allowing duplicate entries. I have no idea how i can stop duplicate entries to be copied.
Sub Register_Copy()
Application.ScreenUpdating = False
Dim copySheet As Worksheet
Dim pasteSheet As Worksheet
Set copySheet = Worksheets("RACF ID")
Set pasteSheet = Worksheets("Sheet1")
copySheet.Range("C4").Copy
pasteSheet.Cells(Rows.count, 1).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
copySheet.Range("B6").Copy
pasteSheet.Cells(Rows.count, 1).End(xlUp).Offset(0, 1).PasteSpecial xlPasteValues
copySheet.Range("C6").Copy
pasteSheet.Cells(Rows.count, 1).End(xlUp).Offset(0, 2).PasteSpecial xlPasteValues
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
It will be faster, if you avoid copy and pasting, but you record the value as a String variable and then write this string variable in column. Thus, you can also check whether the variable exists in the column before writing it.
Public Sub TestMe()
Dim newValue As Variant
newValue = copysheet.Range("C4").Value2
With pastesheet
If IsError(WorksheetFunction.Match(newValue, .Columns(3), 0)) Then
.Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0) = newValue
End If
End With
End Sub
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
So i have to copy cells A1, B2 and C3 from one workbook and add a row in anotherworkbook(in the last line) with theses values in the columns A,B,C.
Here's what i got so far, i think i'm close but i cant finish.
I havo no idea whats wrong with this syntax "Set lastrow = wNew.Cells.(Rows.Count, "A").End(xlUp).Row + 1" that seens to be the problem
Sub Botão1_Clique()
Dim wks As Worksheet
Dim wNew As Worksheet
Dim y As Workbook
Dim lastrow As Long
Application.ScreenUpdating = False
Set wks = ActiveSheet
Set y = Workbooks.Open("Y:\teste.xlsx")
Set wNew = y.Sheets("GERAL")
Set lastrow = wNew.Cells.(Rows.Count, "A").End(xlUp).Row + 1
wks.Cells(1, 1).Copy
wNew.Cells(lastrow, 1).PasteSpecial Paste:=xlPasteValues
wks.Cells(2, 2).Copy
wNew.Cells(lastrow, 2).PasteSpecial Paste:=xlPasteValues
wks.Cells(3, 3).Copy
wNew.Cells(lastrow, 3).PasteSpecial Paste:=xlPasteValues
Application.ScreenUpdating = True
End Sub
I also would like to close the Y:\teste.xlsx workbook, and display a message saying "ROW ADDED"
You do a good job properly referencing Workbooks and Worksheets but also make sure you fully qualify Cells and Rows. They are properties of the worksheet object I.e. ThisWorkbook.Worksheets("..").Rows
Sub Botão1_Clique()
Dim wks As Worksheet, wNew As Worksheet
Dim y As Workbook
Dim lastrow As Long
Application.ScreenUpdating = False
Set wks = ActiveSheet
Set y = Workbooks.Open("Y:\teste.xlsx")
Set wNew = y.Sheets("GERAL")
With wNew
lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
.Cells(lastrow, 1).Value = wks.Cells(1, 1)
.Cells(lastrow, 2).Value = wks.Cells(2, 2)
.Cells(lastrow, 3).Value = wks.Cells(3, 3)
End With
'extra code as requested
y.Close True 'save changes if TRUE
MsgBox "ROW ADDED"
Application.ScreenUpdating = True
End Sub