vba to sort the data into matrix form - vba

I have some data, for the first column date, it contains two dates.
Then I have the fund code and the categories, the last column is the categories value.
How shall I put them into matrix format, for example, the categories is horizontal and the value correspond to the fund name and categories and the date.

Following code should be helpful.
Option Explicit
Sub Demo()
With Application
.ScreenUpdating = False 'stop screen flickering
.Calculation = xlCalculationManual 'prevent calculation while execution
End With
Dim i As Long, lastrow As Long, tblLastRow As Long, tblLastColumn As Long
Dim dict As Object
Dim rng As Variant
Dim ws As Worksheet
Dim cel As Range, dateRng, fundCodeRng As Range, categoryRng As Range, valueRng As Range
Set dict = CreateObject("Scripting.Dictionary")
Set ws = ThisWorkbook.Worksheets("Sheet1") 'change Sheet1 to your worksheet
With ws
lastrow = .Range("A" & .Rows.Count).End(xlUp).Row 'get last row with data
'set ranges for date, fund code, category and value to be used later in code
Set dateRng = .Range("A2:A" & lastrow)
Set fundCodeRng = .Range("B2:B" & lastrow)
Set categoryRng = .Range("C2:C" & lastrow)
Set valueRng = .Range("D2:D" & lastrow)
'get unique records for date and fund coding combined together
For i = 2 To lastrow
dict(.Cells(i, 1).Value & "|" & .Cells(i, 2).Value) = dict(.Cells(i, 1).Value & "|" & .Cells(i, 2).Value)
Next
With .Range("F2").Resize(dict.Count) 'date and fund code will be displayed from cell F2
.Value = Application.Transpose(dict.Keys)
.TextToColumns Destination:=.Cells, DataType:=xlDelimited, Other:=True, OtherChar:="|"
.Offset(, 2).Resize(dict.Count).Value = Application.Transpose(dict.Items)
End With
'empty dictionary
dict.RemoveAll
Set dict = Nothing
Set dict = CreateObject("Scripting.Dictionary")
'get unique categories and display as header
rng = .Range("C1:C" & lastrow)
For i = 2 To UBound(rng)
dict(rng(i, 1) & "") = ""
Next
.Range("H1").Resize(1, UBound(dict.Keys()) + 1).Value = dict.Keys 'categories will be displayed from column H
tblLastRow = .Range("F" & Rows.Count).End(xlUp).Row 'get last row in new table
tblLastColumn = Cells(1, Columns.Count).End(xlToLeft).Column 'get last column of category in new table
'display corresponding values for date, fund code and category
For Each cel In .Range(.Cells(2, 8), .Cells(tblLastRow, tblLastColumn)) 'Cells(2, 8) represent Cell("H2")
cel.FormulaArray = "=IFERROR(INDEX(" & valueRng.Address & ",MATCH(1,(" & dateRng.Address & "=" & .Cells(cel.Row, 6) & ")*(" & fundCodeRng.Address & "=""" & .Cells(cel.Row, 7) & """)*(" & categoryRng.Address & "=""" & .Cells(1, cel.Column) & """),0)),"""")"
cel.Value = cel.Value
Next cel
End With
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With
End Sub
See image for reference.
EDIT :
If Fund Code could be numbers also then replace
cel.FormulaArray = "=IFERROR(INDEX(" & valueRng.Address & ",MATCH(1,(" & dateRng.Address & "=" & .Cells(cel.Row, 6) & ")*(" & fundCodeRng.Address & "=""" & .Cells(cel.Row, 7) & """)*(" & categoryRng.Address & "=""" & .Cells(1, cel.Column) & """),0)),"""")"
with
cel.FormulaArray = "=IFERROR(INDEX(" & valueRng.Address & ",MATCH(1,(" & dateRng.Address & "=" & .Cells(cel.Row, 6) & ")*(Text(" & fundCodeRng.Address & ",""0"")=""" & .Cells(cel.Row, 7) & """)*(" & categoryRng.Address & "=""" & .Cells(1, cel.Column) & """),0)),"""")"

Related

Highlight cells based on cell content with Excel VBA

This is for an Microsoft Excel VBA macro. What it is supposed to do, for every row, when "Late" is entered into column C, to highlight the cell 2 spaces to the left and Range of cells 3 spaces to the right through 43. So example is C4 contains "Late", highlight A4 and F4:AW4. Same goes for the word "Hold" just a different color.
Private Sub Highlight_Condition(ByVal Target As Range)
Dim lastRow As Long
Dim cell As Range
Dim i As Long
With ActiveSheet
lastRow = .Cells(.Rows.Count, "C").End(xlUp).Row
Application.EnableEvents = False
For i = lastRow To 1 Step -1
If .Range("C" & i).Value = "LATE" Then
Debug.Print "Checking Row: " & i
.Range("A" & i).Interior.ColorIndex = 39
.Range("F" & i & ":AW" & i).Interior.ColorIndex = 39
ElseIf .Range("C" & i).Value = "HOLD" Then
.Range("A" & i).Interior.ColorIndex = 43
.Range("F" & i & ":AW" & i).Interior.ColorIndex = 43
Else
.Range("A" & i & ":AW" & i).ClearContents
.Range("F" & i & ":AW" & i).ClearContents
End If
Next i
Application.EnableEvents = True
End With
End Sub
This should work for you...
Private Sub Highlight_Condition(ByVal Target As Range)
Dim lastRow As Long
Dim cell As Range
Dim i As Long
With ActiveSheet
lastRow = .Cells(.Rows.Count, "C").End(xlUp).Row
Application.EnableEvents = False
For i = lastRow To 1 Step -1
If .Range("C" & i).Value = "LATE" Then
Debug.Print "Checking Row: " & i
.Range("A" & i).Interior.ColorIndex = 39
.Range("F" & i & ":AW" & i).Interior.ColorIndex = 39
ElseIf .Range("C" & i).Value = "HOLD" Then
.Range("A" & i).Interior.ColorIndex = 43
.Range("F" & i & ":AW" & i).Interior.ColorIndex = 43
Else
.Range("A" & i & ":AW" & i).ClearContents
.Range("F" & i & ":AW" & i).ClearContents
End If
Next i
Application.EnableEvents = True
End With
End Sub
Tested and seems to work fine for me :)
... C4 contains "Late" ... (emphasis mine)
This seems to indicate that Late may be part of a longer string. I will code to that effect.
Conditional formatting rules are a quick method of achieving your cell highlighting and respond as soon as values in column C change without rerunning the sub procedure (unless more values are added below the lastRow).
Option Explicit
Sub Macro1()
Const TEST_COLUMN As String = "D"
Dim lastRow As Long, sSheetName As String
sSheetName = ActiveSheet.Name
With Worksheets(sSheetName)
lastRow = .Cells(.Rows.Count, TEST_COLUMN).End(xlUp).Row
With .Range("A4:A" & lastRow & ", F4:AW" & lastRow)
.FormatConditions.Delete
.FormatConditions.Add Type:=xlExpression, Formula1:="=isnumber(search(""late"", $c4))"
.FormatConditions(.FormatConditions.Count).Interior.ColorIndex = 39
.FormatConditions.Add Type:=xlExpression, Formula1:="=isnumber(search(""hold"", $c4))"
.FormatConditions(.FormatConditions.Count).Interior.ColorIndex = 43
End With
End With
End Sub
Great! I wanted to run this in the worksheet and not as a module. So i added a few extra lines and ByVal Target As Range to fire everytime a change is made in the range but it doesn't seem to work. Am i missing something?
Private Sub Highlight_Condition(ByVal Target As Range)
Dim LastRow As Long
Dim cell As Range
Dim i As Long
With ActiveSheet
LastRow = .Cells(.Rows.Count, "C").End(xlUp).Row
Application.EnableEvents = False
For i = LastRow To 1 Step -1
If .Range("C" & i).Value = "LATE" Then
Debug.Print "Checking Row: " & i
.Range("A" & i).Interior.ColorIndex = 39
.Range("F" & i & ":AW" & i).Interior.ColorIndex = 39
ElseIf .Range("C" & i).Value = "HOLD" Then
.Range("A" & i).Interior.ColorIndex = 43
.Range("F" & i & ":AW" & i).Interior.ColorIndex = 43
Else
.Range("A" & i).EntireRow.Interior.ColorIndex = xlNone
End If
Next i
Application.EnableEvents = True
End With
End Sub

Consolidate data and provide average of the consolidated data

I am writing a macro, which will be used to consolidate data from a range of cells. I have the table with the data that I want to consolidate in sheets("1") in Range D2:J6 and the destination location is again in sheets("1") in M2:R2 (the colums M to R but they contain headers) . I have already written a part of the code below, which applies and runs for them. However, even though it doesnt say it has an error, it just wont run correctly.. I am prividing the screenshot from my excel after the macro runs ..
as you can see from the image, I want to consolidate the duplicate values in row D and print the average of the values located in columns E,F,G, H, I ,J on the same row as the consolidated values in column D. For example for the value "Gebze 6832" in column D, I want to remove it as a duplicate, make it one cell in the destination and print the average of the columns E,F,G, H, I ,J from the two rows that were consolidated next to it in the destination columns.
My code is below (UPDATE)
Dim ws As Worksheet
Dim dataRng As Range
Dim dic As Variant, arr As Variant
Dim cnt As Long
Set ws = Sheets("1")
With ws
lastrow = .Cells(.Rows.Count, "D").End(xlUp).Row 'get last row in Column D
Set dataRng = .Range("D2:D" & lastrow) 'range for Column D
Set dic = CreateObject("Scripting.Dictionary")
arr = dataRng.Value
For i = 1 To UBound(arr)
dic(arr(i, 1)) = dic(arr(i, 1)) + 1
Next
.Range("M2").Resize(dic.Count, 1) = Application.WorksheetFunction.Transpose(dic.keys) 'uniques data from Column D
.Range("Q2").Resize(dic.Count, 1) = Application.WorksheetFunction.Transpose(dic.items)
cnt = dic.Count
For i = 2 To cnt + 1
.Range("N" & i & ":P" & i).Formula = "=SUMIF($D$2:$D$" & lastrow & ",$M" & i & ",E$2:E$" & lastrow & ")/" & dic(.Range("M" & i).Value)
.Range("R" & i).Formula = "=IF(INDEX($I$2:$I$" & lastrow & ",MATCH($M" & i & ",$D$2:$D$" & lastrow & ",0))=0,N" & i & ","""")"
.Range("S" & i).Formula = "=IF(INDEX($I$2:$I$" & lastrow & ",MATCH($M" & i & ",$D$2:$D$" & lastrow & ",0))=0,Q" & i & ","""")"
.Range("T" & i).Formula = "=IF($S" & i & ">0,SUMPRODUCT(($D$2:$D$" & lastrow & "=$M" & i & ")*(($J$2:$J$" & lastrow & "-$E$2:$E$" & lastrow & ")>3%)),"""")"
Next i
.Range("M" & i).Value = "Grand Total"
.Range("N" & i & ":P" & i).Formula = "=AVERAGE(N2:N" & cnt + 1 & ")"
.Range("Q" & i).Formula = "=SUM(Q2:Q" & cnt + 1 & ")"
.Range("R" & i).Formula = "=AVERAGE(R2:R" & cnt + 1 & ")"
.Range("S" & i & ":T" & i).Formula = "=SUM(S2:S" & cnt + 1 & ")"
.Range("N2:T" & .Cells(.Rows.Count, "M").End(xlUp).Row + 1).Value = .Range("N2:T" & .Cells(.Rows.Count, "M").End(xlUp).Row + 1).Value
End With
Assuming your data is in range Column D to Column J starting from Row 2 and output has to be displayed from Column M to Column S from Row 2 following might be helpful.
Sub Demo()
Dim ws As Worksheet
Dim dataRng As Range
Dim dic As Variant, arr As Variant
Dim cnt As Long
Set ws = ThisWorkbook.Sheets("Sheet4") 'change Sheet4 to your data sheet
Application.ScreenUpdating = False
With ws
lastRow = .Cells(.Rows.Count, "D").End(xlUp).Row 'get last row in Column D
Set dataRng = .Range("D2:D" & lastRow) 'range for Column D
Set dic = CreateObject("Scripting.Dictionary")
arr = dataRng.Value
For i = 1 To UBound(arr)
dic(arr(i, 1)) = dic(arr(i, 1)) + 1
Next
.Range("M2").Resize(dic.Count, 1) = Application.WorksheetFunction.Transpose(dic.keys) 'uniques data from Column D
cnt = dic.Count
For i = 2 To cnt + 1
.Range("N" & i & ":S" & i).Formula = "=SUMIF($D$2:$D$" & lastRow & ",$M" & i & ",E$2:E$" & lastRow & ")/" & dic(.Range("M" & i).Value)
Next i
.Range("N2:S" & .Cells(.Rows.Count, "M").End(xlUp).Row).Value = .Range("N2:S" & .Cells(.Rows.Count, "M").End(xlUp).Row).Value
End With
Application.ScreenUpdating = True
End Sub
This code will give following result.

VBA for matching Sheet 1 columns to Sheet 2 columns

Sheet 1 has columns A-T. Some columns of Sheet 1 have formulas and others have a dropdown list.
Sheet 2 has columns A-P. I want to be able to paste the Sheet 1 data in Sheet 2-- The data generated as a result of formulas and drop downs. Also in a way, that if I change anything in Sheet 1 it changes on the other sheet. I want to be able to do this for multiple columns.
The thing is that Sheet 1 and Sheet 2 columns are not true to each other. I mean Column A of Sheet 1 is Column C in Sheet 2 etc..
Right now, I have simply equaled the cells using formula on both sheets to make this work. I don't wish to continue it this way. Macro will be better.
Thank you! Please help.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Rng As Range, Rc As Range, R As Long
Dim hC As String, Lr As Long
Dim Ws2 As Worksheet
On Error GoTo mExit
Set Ws2 = Worksheets("Sheet 2")
hC = "AO"
Application.EnableEvents = False
Set Rng = Application.Intersect(Target, Columns("A:T"))
If Not Rng Is Nothing Then
For Each Rc In Rng.Rows
R = Rc.Row
If Range(hC & R).HasFormula Then
Lr = Ws2.Range(Range(hC & R).Formula).Row
Else
With Ws2
Lr = .Range(hC & .Rows.Count).End(xlUp).Row + 1
Range(hC & R).Formula = "='" & .Name & "'!" & hC & Lr
End With
End If
With Ws2
.Range("B" & Lr).Value = Range("A" & R).Value
.Range("C" & Lr).Value = Range("C" & R).Value
.Range("D" & Lr).Value = Range("D" & R).Value
.Range("E" & Lr).Value = Range("E" & R).Value
.Range("F" & Lr).Value = Range("F" & R).Value
.Range("G" & Lr).Value = Range("G" & R).Value
.Range("H" & Lr).Value = Range("H" & R).Value
.Range("I" & Lr).Value = Range("I" & R).Value
.Range("J" & Lr).Value = Range("J" & R).Value
.Range("K" & Lr).Value = Range("AH" & R).Value
.Range("L" & Lr).Value = Range("K" & R).Value
.Range("M" & Lr).Value = Range("L" & R).Value
.Range("N" & Lr).Value = Range("M" & R).Value
.Range("O" & Lr).Value = Range("N" & R).Value
.Range("P" & Lr).Value = Range("AA" & R).Value
.Range(hC & Lr).Value = "Related"
End With
Next
End If
mExit:
Application.EnableEvents = True
End Sub
Edited Code (3_31_3017)
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Rng As Range, Rc As Range, R As Long
Dim hC As String, Lr As Long
Dim Ws2 As Worksheet
On Error GoTo mExit
Set Ws2 = Worksheets("Route_Sheet")
hC = "AP"
Application.EnableEvents = False
Set Rng = Application.Intersect(Target, Columns("A:AL"))
If Not Rng Is Nothing Then
For Each Rc In Rng.Rows
R = Rc.Row
If Range(hC & R).HasFormula Then
Lr = Ws2.Range(Range(hC & R).Formula).Row
Else
With Ws2
Lr = .Range(hC & .Rows.Count).End(xlUp).Row + 1
Range(hC & R).Formula = "='" & .Name & "'!" & hC & Lr
End With
End If
With Ws2
.Range("B" & Lr).Value = Range("A" & R).Value
.Range(.Cells(Lr, "C"), .Cells(Lr, "J")).Value = Range(Cells(R, "C"), Cells(R, "J")).Value
.Range(.Cells(Lr, "L"), .Cells(Lr, "O")).Value = Range(Cells(R, "K"), Cells(R, "N")).Value
.Range("K" & Lr).Value = Range("AH" & R).Value
.Range("P" & Lr).Value = Range("AA" & R).Value
.Range("Q" & Lr).Value = Range("U" & R).Value
.Range(hC & Lr).Value = "Related"
End With
Next
End If
mExit:
Application.EnableEvents = True
End Sub
We need at least one thing to know that row(x) in Sheet 1 is related to row(y) in Sheet 2. this can be done by adding unique identifier for each row as #tigeravatar mentioned or by adding one formula in unused column in row(x) in Sheet 1 relating to row(y) in Sheet 2.
In Sheet 1 Module add this:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Rng As Range, Rc As Range, R As Long
Dim hC As String, Lr As Long
Dim Ws2 As Worksheet
On Error GoTo mExit
Set Ws2 = Worksheets("Sheet 2")
hC = "U" 'Change this to any unused column and You can hide it
Application.EnableEvents = False
Set Rng = Application.Intersect(Target, Columns("A:T"))
If Not Rng Is Nothing Then
For Each Rc In Rng.Rows
R = Rc.Row
If Range(hC & R).HasFormula Then
Lr = Ws2.Range(Range(hC & R).Formula).Row
Else
With Ws2
Lr = .Range(hC & .Rows.Count).End(xlUp).Row + 1
Range(hC & R).Formula = "='" & .Name & "'!" & hC & Lr
End With
End If
With Ws2
' Add here all columns you need like :
'=====================================
.Range("C" & Lr).Value = Range("A" & R).Value
.Range("A" & Lr).Value = Range("B" & R).Value
'...etc
'=====================================
.Range(hC & Lr).Value = "Related"
End With
Next
End If
mExit:
Application.EnableEvents = True
End Sub
Edit:
Right click on "Master" sheet tab and select View Code and paste this code in it:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Rng As Range, Rc As Range, R As Long
Dim hC As String, Lr As Long
Dim Ws2 As Worksheet
On Error GoTo mExit
Set Ws2 = Worksheets("Sheet 2") 'Change "Sheet 2" to your target sheet name like "Route_Sheet" or "Lists"
hC = "AO"
Application.EnableEvents = False
Set Rng = Application.Intersect(Target, Columns("A:AH"))
If Not Rng Is Nothing Then
For Each Rc In Rng.Rows
R = Rc.Row
If Range(hC & R).HasFormula Then
Lr = Ws2.Range(Range(hC & R).Formula).Row
Else
With Ws2
Lr = .Range(hC & .Rows.Count).End(xlUp).Row
If Not (Lr = 1 And .Range(hC & Lr).Value = vbNullString) Then Lr = Lr + 1
Range(hC & R).Formula = "='" & .Name & "'!" & hC & Lr
End With
End If
With Ws2
.Range("B" & Lr).Value = Range("A" & R).Value
.Range(.Cells(Lr, "C"), .Cells(Lr, "J")).Value = Range(Cells(R, "C"), Cells(R, "J")).Value
.Range(.Cells(Lr, "L"), .Cells(Lr, "O")).Value = Range(Cells(R, "K"), Cells(R, "N")).Value
.Range("K" & Lr).Value = Range("AH" & R).Value
.Range("P" & Lr).Value = Range("AA" & R).Value
.Range(hC & Lr).Value = "Related"
End With
Next
End If
mExit:
Application.EnableEvents = True
End Sub
This is a Worksheet Event that run automatically when user change any cell inside Columns("A:AH").
If you want to run it manually you can add new sub in Module1:
Sub Test()
With sheets("Master").Range("A2:A50") ' change this range to all rows you need like "A5:A100"
.Value = .Value
End With
End Sub
Or:
Sub Test()
With Sheets("Master")
Application.Run .CodeName & ".Worksheet_Change", .Range("A1:A50") 'change this range to all rows you need like "A5:A100"
End With
End Sub

Find matching cell with different strings inside one cell

My goal of my macro:
I have 2 sheets, sheet1 master report and sheet2 import Input.
In column A of both sheets I have several strings in one cell.
I would like to see if there is a match and if there is the match the row from sheet2 (from column B) will be copied and paste in the row corresponding in sheet1.
This part of my code is done.
But now it starts to be tricky: If there is new string in the same cell as the matching string so I would like to add them as well in the cell of the column A sheet1.
For instance:
Sheet1 Column A Cell34:
MDM-9086
Sheet2 Column A Cell1:
MDM-9086,MDM-12345
After the macro it would be like this:
Sheet1 Column A cell34:
MDM-9086,MDM-12345
If there is no match between column A of both sheets so I would like to copy the entire row of the sheet2 and past it in the last free row of the sheet1.
See my code:
Sub MDMNumbers()
Dim LastRw1 As Long, LastRw2 As Long, NxtRw As Long
Dim I As Integer
Dim m As Range
Dim Tb
LastRw1 = Sheets(1).Range("A" & Rows.Count).End(xlUp).Row
LastRw2 = Sheets(2).Range("A" & Rows.Count).End(xlUp).Row
With Worksheets(2)
LastRw2 = .Range("A" & Rows.Count).End(xlUp).Row
For NxtRw = 2 To LastRw2
Tb = Split(.Range("A" & NxtRw), ",")
For I = 0 To UBound(Tb)
With Sheets(1).Range("A2:A" & LastRw1)
Set m = .Find(Trim(Tb(I)), LookAt:=xlPart)
If Not m Is Nothing Then
Sheets(2).Range("B" & NxtRw & ":Q" & NxtRw).Copy _
Sheets(1).Range("B" & m.Row)
Set m = Nothing
End If
End With
Next I
Next NxtRw
End With
End Sub
Example:
Sheet 1, Column A (start row 2)
MDM-123,MDM-27827
MDM-1791728,MDM-124
MDM-125
MDM-126,MDM-28920
MDM-127,MDM-1008
""
Sheet 2, Column A (start row 2)
MDM-123,MDM-27272
MDM-124
MDM-125,MDM-1289
MDM-126
MDM-1008
MDM-127
MDM-172891
Result on Sheet 1, Column A (start row 2):
MDM-123,MDM-27827,MDM-27272
MDM-124,MDM-1791728
MDM-125,MDM-1289
MDM-126,MDM-28920
MDM-127,MDM-1008
MDM-1008
MDM-172891
For your # 2.
Option Explicit
Public Sub MDMNumbers()
Dim LastRw1 As Long, LastRw2 As Long, NxtRw As Long, rng1 As Range, rng2 As Range
Dim i As Long, m As Range, tb() As String, celVal As String, notFound As Boolean
Dim additions1 As String, additions2 As String
LastRw1 = Worksheets(1).Range("A" & Worksheets(1).Rows.Count).End(xlUp).Row + 1
LastRw2 = Worksheets(2).Range("A" & Worksheets(2).Rows.Count).End(xlUp).Row
notFound = True
For NxtRw = 2 To LastRw2
celVal = Worksheets(2).Range("A" & NxtRw).Value2
If Len(celVal) > 0 Then
tb = Split(celVal, ",")
For i = 0 To UBound(tb)
Set m = Worksheets(1).Columns(1).Find(Trim(tb(i)), LookAt:=xlPart)
If Not m Is Nothing And notFound Then
Set rng1 = Worksheets(2).Range("B" & NxtRw & ":Q" & NxtRw)
Set rng2 = Worksheets(1).Range("B" & m.Row & ":Q" & m.Row)
rng1.Copy rng2
With Worksheets(2).Range("A" & NxtRw)
additions1 = Replace(.Value2, "," & tb(i), vbNullString)
additions1 = Replace(additions1, tb(i) & ",", vbNullString)
additions1 = Replace(additions1, tb(i), vbNullString)
End With
With Worksheets(1).Range("A" & m.Row)
additions2 = Replace(.Value2, "," & tb(i), vbNullString)
additions2 = Replace(additions2, tb(i) & ",", vbNullString)
additions2 = Replace(additions2, tb(i), vbNullString)
If Len(additions2) > 0 Then
If Len(additions1) > 0 Then
.Value2 = tb(i) & "," & additions2 & "," & additions1
Else
.Value2 = tb(i) & "," & additions2
End If
Else
.Value2 = tb(i) & "," & additions1
End If
End With
Set m = Nothing
notFound = False
End If
Next
If notFound Then
Set rng1 = Worksheets(2).Range("A" & NxtRw & ":Q" & NxtRw)
Set rng2 = Worksheets(1).Range("A" & LastRw1 & ":Q" & LastRw1)
rng1.Copy rng2
LastRw1 = LastRw1 + 1
End If
notFound = True
End If
Next
End Sub
It should work as expected now
Test data and result:
Why don't you copy the whole row from sheet2 to sheet1 like
For NxtRw = 2 To LastRw2
...
Sheets(2).Range("A" & NxtRw & ":Q" & NxtRw).Copy _
Sheets(1).Range("A" & m.Row)
...
Next NxtRw
? (The rest of the loop should stay the same.)

How to increase only last digit of a serial number string in Excel VBA?

I'm new to vba and trying to write a barcode scanner algorithm. It works fine right now but I want to keep serial numbers in my exel table and their structure has to be like "A151000". I want with each barcode entered a cell with an inputbox also be assigned to a serial number. for example when a new entry(Barcode) written in column C I want in column B serial numbers last digit increased by 1 and stored in that cell automatically.
Right now I can drag the cell from corner and exel increases the last digit. How can I trigger this with new entries automatically? Thanks in advance.
A151000
A151001
A151002
...
Sub DataInput()
Dim SearchTarget As String
Dim myRow As Long
Dim Rng As Range
Static PrevCell As Range
Dim FoundCell As Range
Dim CurCell As Range
Dim a As String
Dim Target As Range
Dim buttonclick As Boolean
V = True
If PrevCell Is Nothing Then
myRow = Selection.Row
Set PrevCell = Range("C" & myRow)
End If
Set Rng = Range("C:C,C:C") 'Columns for search defined here
With Rng
Set FoundCell = .Cells.Find(What:=SearchTarget, _
After:=PrevCell, LookIn:=xlFormulas, LookAt:= _
xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, _
MatchCase:=True)
End With
Dim Eingabezahl As String
Do While Eingabezahl! = ""
Eingabezahl = InputBox("Last barcode scanned" & " " & Eingabezahl)
Range("C" & Range("C" & Rows.Count).End(xlUp).Row + 1) = Eingabezahl
Range("D" & Range("D" & Rows.Count).End(xlUp).Row + 1) = Now()
Range("E" & Range("E" & Rows.Count).End(xlUp).Row + 1) = "VALID"
Loop
End Sub
TO use the Autofill function and not change your original code you could just add in the autofill in your sub:
Dim Eingabezahl As String
Dim rngLastBCell As Range
Do While Eingabezahl = ""
Eingabezahl = InputBox("Last barcode scanned" & " " & Eingabezahl)
Set rngLastBCell = Range("B" & Rows.Count).End(xlUp)
rngLastBCell.AutoFill Destination:=Range(rngLastBCell, rngLastBCell.Offset(1)), Type:=xlFillDefault
Range("C" & Range("C" & Rows.Count).End(xlUp).Row + 1) = Eingabezahl
Range("D" & Range("D" & Rows.Count).End(xlUp).Row + 1) = Now()
Range("E" & Range("E" & Rows.Count).End(xlUp).Row + 1) = "VALID"
Loop
Or you could use the following that using the same concept (an autofill) but condenses al of your calls to the worksheet into a single line:
Dim Eingabezahl As String
Dim rngLastBCell As Range
Do While Eingabezahl = ""
Eingabezahl = InputBox("Last barcode scanned" & " " & Eingabezahl)
Set rngLastBCell = Range("B" & Rows.Count).End(xlUp)
rngLastBCell.AutoFill Destination:=Range(rngLastBCell, rngLastBCell.Offset(1)), Type:=xlFillDefault
rngLastBCell.Offset(1, 1).Resize(, 3) = Array(Eingabezahl, Now(), "VALID")
Loop
Although I would recommend just using appenending the current row to the end of your serial and not making as many calls to the worksheet by using an array:
Dim rngB As Range
Dim Eingabezahl As String
Dim SerialBase As String
SerialBase = "A15100"
Do While Eingabezahl = ""
Eingabezahl = InputBox("Last barcode scanned" & " " & Eingabezahl)
Set rngB = Range("B" & Rows.Count).End(xlUp).Offset(1)
rngB.Resize(, 4).Value = Array(SerialBase & rngB.Row, Eingabezahl, Now(), "VALID")
Loop