I want to retrieve data in a row with the name and the header.
I really appreciate your help
NAME AUG 1, 2019 AUG 2, 2019 AUG 3, 2019
Zoldyk,Hunter 5 7
Luffy,One 1 2 3
Sub Button1_Click()
Dim rngCopy As Range, rngTemp As Range, rngTarget As Range
Dim intMultiple As Integer, i As Integer, intRow As Integer
Dim objSheet As Worksheet
Set objSheet = Sheets(1)
Dim intLastCellIndexInRow As Integer
intLastCellIndexInRow = ActiveCell.SpecialCells(xlLastCell).Column
Dim strRowValue As String
Dim j As Integer
Set rngCopy = Sheet1.Range("A2", Sheet1.Cells(Sheet1.Rows.Count, 1).End(xlUp)) 'Set range including names
Set rngTarget = Sheet1.Cells(Sheet1.Rows.Count, 1).End(xlUp).Offset(1, 0) 'Set target range to next available row in Sheet2
`For intRow = rngCopy.Rows.Count To 1 Step -1
Set rngTemp = rngCopy.Cells(intRow)
intMultiple = rngTemp.Offset(0, 1) 'Find how many times to copy the name
For i = 1 To intMultiple
For j = 3 To intLastCellIndexInRow
rngTarget.Value = rngTemp.Value 'Copy name
rngTarget.Next.Value = objSheet.Cells(ActiveCell.Row, j) 'Copy ID
Set rngTarget = rngTarget.Offset(1, 0) 'Move target range to next row
Next
Next
Next
End Sub
Zoldyk,hunter|5|aug 1,2019
Zoldyk,hunter| |aug 2,2019
Zoldyk,hunter|7|aug 3,2019
Luffy,One |1|aug 1,2019
Luffy,One |2|aug 2,2019
Luffy,One |3|aug 3,2019
Notes:
Didn't understand your loop,so I have changed it completely
Try and remove the extra declarations that are left in the code.
You can manipulate it to print on other sheet.
You can also use Pivot for this.
Use the Below code :
Sub Button1_Click()
Dim rngCopy As Range, rngTemp As Range, rngTarget As Range
Dim intMultiple As Integer, i As Integer, intRow As Integer
Dim objSheet As Worksheet
Set objSheet = Sheets(1)
Dim strRowValue As String
Dim j As Integer
Dim cl As Integer
Set rngCopy = Sheet1.Range("A2", Sheet1.Cells(Sheet1.Rows.Count, 1).End(xlUp)) 'Set range including names
Set rngTarget = Sheet1.Cells(Sheet1.Rows.Count, 1).End(xlUp).Offset(1, 0) 'Set target range to next available row in Sheet2\
cl = Sheet1.Range("A1").End(xlToRight).Column
i = rngTarget.row
For Each cel In rngCopy.Cells
For j = 2 To cl
With Sheet1
.Range("A" & i).Value = cel.Value
.Range("B" & i).Value = .Cells(cel.row, j).Value
.Range("C" & i).Value = .Cells(1, j).Value
i = i + 1
End With
Next
Next
End Sub
Demo:
Related
I am trying to write a macro that will look in column A on sheet1 and see if it is missing any values from column A on sheet2 or column A on sheet3. If it is missing have the value added to the bottom of the column A on sheet1. The same value may exist on sheet2 and sheet3 but it only needs to be represented once on sheet1.
I'm working with the code below.
Sub newRow()
Dim rngSh1 As Range, rngSh2 As Range, rngSh3 As Range, mySelSh2 As Range, mySelSh3 As Range
Dim lastRowSh1 As Long, lastRowSh2 As Long, lastRowSh3 As Long
Dim wb As Worksheet
Dim cell As Range
Set wb = ThisWorkbook
With wb
lastRowSh1 = Worksheets("Sheet1").Range("A" & .Rows.Count).End(xlUp).Row
lastRowSh2 = Worksheets("Sheet2").Range("A" & .Rows.Count).End(xlUp).Row
lastRowSh3 = Worksheets("Sheet3").Range("A" & .Rows.Count).End(xlUp).Row
Set rngSh1 = Worksheets("Sheet1").Range("A1:A" & lastRowSh1)
Set rngSh2 = Worksheets("Sheet2").Range("A1:A" & lastRowSh2)
Set rngSh3 = Worksheets("Sheet3").Range("A1:A" & lastRowSh3)
End With
For Each cell In rngSh2.Cells
If IsError(Application.Match(cell.Value, rngSh1, 0)) Then
If mySelSh2 Is Nothing Then
Set mySelSh2 = cell
Else
Set mySelSh2 = Union(mySelSh2, cell)
End If
End If
Next cell
If Not mySelSh2 Is Nothing Then mySelSh2.Copy Destination:=Worksheets("Sheet1").Range("A" & lastRowSh1 + 1)
For Each cell In rngSh3.Cells
If IsError(Application.Match(cell.Value, rngSh1, 0)) Then
If mySelSh3 Is Nothing Then
Set mySelSh3 = cell
Else
Set mySelSh3 = Union(mySelSh3, cell)
End If
End If
Next cell
If Not mySelSh3 Is Nothing Then mySelSh3.Copy Destination:=Worksheets("Sheet1").Range("A" & lastRowSh1 + 1)
End Sub
I've made every adjustment I can think of but with every change I make I get a different error.
Any help would be greatly appreciated. Thanks!
Save yourself a little bit of time using a Scripting.Dictionary:
Option Explicit
Sub test()
Dim dict As New Scripting.dictionary, sheetNum As Long
For sheetNum = 2 To Sheets.Count
With Sheets(sheetNum)
Dim lastRow As Long: lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
Dim rowNum As Long
For rowNum = 1 To lastRow
Dim dictVal As Long: dictVal = .Cells(rowNum, 1).Value
If Not dict.Exists(dictVal) Then dict.Add dictVal, 0
Next rowNum
End With
Next sheetNum
With Sheets(1)
Dim checkableRangeLastRow As Long: checkableRangeLastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
Dim checkableRange As Range: Set checkableRange = .Range(.Cells(1, 1), .Cells(checkableRangeLastRow, 1))
Dim dictKey As Variant
For Each dictKey In dict.Keys
If IsError(Application.Match(dictKey, checkableRange, 0)) = True Then
lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
.Cells(lastRow + 1, 1).Value = dictKey
End If
Next dictKey
End With
End Sub
You add all values in your not-master-sheet into dict then loop through that list; if it's not found in your master-sheet, then you add then to the end of the list.
A significant note is that the Type of value used as the dictVal may cause the IsError() statement to always be True if it is not the same Type as the data being assessed in the checkableRange.
I have a workbook includes 2 sheets.
In each sheet, it has couple columns like Name(column A), State(column B) and ID (column C). But the rows' sort sequence of two sheets are both random.
According to IDs, I need to use VBA to compare the value of Name and State.
If they don't match, then highlight both of 2 cells in 2 sheets.
The result should be like this:
But my code below can only run for Column A if IDs have the same order sequence.
I understand that it can be much easier if I use conditional formatting to create a new rule or use vlookup or index and match function to compare. But I am asked to use VBA
Thank you!
Sub Test_Sheet()
Dim sheetOne As Worksheet
Dim sheetTwo As Worksheet
Dim lastRow As Long
Dim lastRow2 As Long
Dim thisRow As Long
Dim thisRow2 As Long
Dim lastCol As Long
Dim lastCol2 As Long
Dim thisCol As Long
Dim thisCol2 As Long
Dim foundRow As Range
Dim foundRow2 As Range
Dim lastFoundRow As Long
Dim lastFoundRow2 As Long
Dim searchRange As Range
Dim searchRange2 As Range
Dim isMatch As Boolean
Dim isMatch2 As Boolean
' Set up the sheets
Set sheetOne = Sheets("Sheet1")
Set sheetTwo = Sheets("Sheet2")
' Find the last row of the active sheet
lastRow = sheetOne.Cells(sheetOne.Rows.Count, "A").End(xlUp).Row
lastRow2 = sheetOne.Cells(sheetOne.Rows.Count, "B").End(xlUp).Row
' Set the search range on the other sheet
Set searchRange = sheetTwo.Range("A2:A" & sheetTwo.Cells(sheetTwo.Rows.Count, "A").End(xlUp).Row)
Set searchRange2 = sheetTwo.Range("B2:B" & sheetTwo.Cells(sheetTwo.Rows.Count, "B").End(xlUp).Row)
' Look at all rows
For thisRow = 1 To lastRow
' Find the last column on this row
lastCol = sheetOne.Cells(thisRow, sheetOne.Columns.Count).End(xlToLeft).Column
' Find the first match
Set foundRow = searchRange.Find(sheetOne.Cells(thisRow, "A").Value, searchRange(searchRange.Count), xlValues, xlWhole)
' Must find something to continue
Do While Not foundRow Is Nothing
' Remember the row we found it on
lastFoundRow = foundRow.Row
' Check the found row has the same number of columns
If sheetTwo.Cells(lastFoundRow, sheetTwo.Columns.Count).End(xlToLeft).Column = lastCol Then
' Assume it's a match
isMatch = True
' Look at all the column values
For thisCol = 1 To lastCol
' Compare the column values
If sheetTwo.Cells(lastFoundRow, thisCol).Value <> sheetOne.Cells(thisRow, thisCol).Value Then
' No match
isMatch = False
Exit For
End If
Next thisCol
' If it's still a match then highlight the row
If isMatch Then sheetOne.Range(sheetOne.Cells(thisRow, "A"), sheetOne.Cells(thisRow, lastCol)).Interior.ColorIndex = 3
End If
' Find the next match
Set foundRow = searchRange.Find(sheetOne.Cells(thisRow, "A").Value, foundRow, xlValues, xlWhole)
' Quit out when we wrap around
If foundRow.Row <= lastFoundRow Then Exit Do
Loop
Next thisRow
For thisRow2 = 1 To lastRow2
lastCol2 = sheetOne.Cells(thisRow2, sheetOne.Columns.Count).End(xlToLeft).Column
Set foundRow2 = searchRange2.Find(sheetOne.Cells(thisRow2, "B").Value, searchRange2(searchRange2.Count), xlValues, xlWhole)
Do While Not foundRow2 Is Nothing
lastFoundRow2 = foundRow2.Row
If sheetTwo.Cells(lastFoundRow2, sheetTwo.Columns.Count).End(xlToLeft).Column = lastCol2 Then
isMatch2 = True
For thisCol2 = 1 To lastCol2
If sheetTwo.Cells(lastFoundRow2, thisCol2).Value <> sheetOne.Cells(thisRow2, thisCol2).Value Then
isMatch2 = False
Exit For
End If
Next thisCol2
If isMatch2 Then sheetOne.Range(sheetOne.Cells(thisRow2, "B"), sheetOne.Cells(thisRow2, lastCol2)).Interior.ColorIndex = 5
End If
Set foundRow2 = searchRange2.Find(sheetOne.Cells(thisRow2, "B").Value, foundRow2, xlValues, xlWhole)
If foundRow2.Row <= lastFoundRow2 Then Exit Do
Loop
Next thisRow2
End Sub
Please, try the next code. It uses arrays, for faster iteration, processing the matching in memory and Union ranges, coloring the cells interior at once, at the end. Modifying the interior of each cell consumes Excel resources and takes time:
Sub testCompareIDs()
Dim sheetOne As Worksheet, sheetTwo As Worksheet, lastRow1 As Long, lastRow2 As Long, i As Long, j As Long
Dim rng1 As Range, rng2 As Range, arr1, arr2, rngColA1 As Range, rngColA2 As Range, rngColB1 As Range, rngColB2 As Range
Set sheetOne = Sheets("Sheet1")
Set sheetTwo = Sheets("Sheet2")
lastRow1 = sheetOne.cells(sheetOne.rows.count, "C").End(xlUp).row
lastRow2 = sheetTwo.cells(sheetOne.rows.count, "C").End(xlUp).row
Set rng1 = sheetOne.Range("A2:C" & lastRow1)
Set rng2 = sheetTwo.Range("A2:C" & lastRow2)
arr1 = rng1.value: arr2 = rng2.value 'place ranges to be processed in arrays, for faster iteration
For i = 1 To UBound(arr1)
For j = 1 To UBound(arr2)
If arr1(i, 3) = arr2(j, 3) Then
If arr1(i, 1) <> arr2(j, 1) Then
If rngColA1 Is Nothing Then
Set rngColA1 = rng1.cells(i, 1)
Set rngColA2 = rng2.cells(j, 1)
Else
Set rngColA1 = Union(rngColA1, rng1.cells(i, 1))
Set rngColA2 = Union(rngColA2, rng2.cells(j, 1))
End If
End If
If arr1(i, 2) <> arr2(j, 2) Then
If rngColB1 Is Nothing Then
Set rngColB1 = rng1.cells(i, 2)
Set rngColB2 = rng2.cells(j, 2)
Else
Set rngColB1 = Union(rngColB1, rng1.cells(i, 2))
Set rngColB2 = Union(rngColB2, rng2.cells(j, 2))
End If
End If
Exit For 'exit iteration since the ID has been found
End If
Next j
Next i
If Not rngColA1 Is Nothing Then
rngColA1.Interior.ColorIndex = 3
rngColA2.Interior.ColorIndex = 3
End If
If Not rngColB1 Is Nothing Then
rngColB1.Interior.ColorIndex = 3
rngColB2.Interior.ColorIndex = 3
End If
End Sub
The strings compare is case sensitive. The code can be adapted to not be case sensitive (using Ucase for each compare line)
Please, send some feedback after testing it.
I am trying to color the cell when condition is met and valid value for package of a product is found in another column in a different sheet.
There is a problem with the if statement.
Sub validation()
Dim lastRow_s As Long
Dim lastRow_m As Long
lastRow_s = Sheets("product").Cells(Rows.Count, "D").End(xlUp).Row
lastRow_m = Sheets("product").Cells(Rows.Count, "H").End(xlUp).Row
For i = 2 To lastRow_s
For j = 2 To lastRow_m
If Sheets("product").Cells(i,"D").Value =
Sheets("valid_package").Cells(j,"A").Value And
Sheets("product").Cells(i, "H").Value =
Sheets("valid_package").Cells(j,"B").Value Then
Sheets("product").Cells(i, "H").Value = vbGreen
End If
Next j
Next i
End Sub
I am trying to iterate over two columns to make sure that the product in column D has a valid package in column H in the product sheet. In the valid_package sheet there is a column for product and package that are valid for this products, so valid_package looks like this:
Product (this is column A from valid package)
Package (this is column B from valid package)
Product A
65x3
Product A
63x3
Product B
65x3
Product B
60x3
Product C
15
Product C
10x3
Product C
15
Product D
10
The product sheet is like this if you take only the two columns:
Product (this is column D from products)
Package (this is column H from products)
Product A
65x3
Product C
63x3
Product B
65x3
Product C
60x3
Product A
15
Product B
10x3
Product C
15
Product E
10
Product C
15
Product D
10
I want to highlight correct package in column H for sheet product or incorrect package in column H for sheet product, it doesn't matter what is colored.
I get
Expected: "line number or label or statement or end of statement.
Color Conditionally Matching Cells
Option Explicit
Sub TestAll()
ValidationQuickFix
ValidationReadable
ValidationEfficient
' Result on 1000 matches in 10000 rows of destination
' with only 10 rows of unique source values:
' Quick Fix: 6,1875
' Readable: 2,21484375
' Efficient: 0,87890625
End Sub
Sub ValidationQuickFix()
Dim t As Double: t = Timer
ThisWorkbook.Activate
Dim lastRow_s As Long
lastRow_s = Worksheets("valid_package").Cells(Rows.Count, "A").End(xlUp).Row
Dim lastRow_d As Long
lastRow_d = Worksheets("product").Cells(Rows.Count, "D").End(xlUp).Row
Dim i As Long, j As Long
For i = 2 To lastRow_d
For j = 2 To lastRow_s
If Worksheets("product").Cells(i, "D").Value = _
Worksheets("valid_package").Cells(j, "A").Value Then
If Worksheets("product").Cells(i, "H").Value = _
Worksheets("valid_package").Cells(j, "B").Value Then
Worksheets("product").Cells(i, "H").Interior.Color = vbGreen
Else
Worksheets("product").Cells(i, "H").Interior.Color = xlNone
End If
End If
Next j
Next i
Debug.Print "Quick Fix: " & Timer - t
End Sub
Sub ValidationReadable()
Dim t As Double: t = Timer
Dim wb As Workbook: Set wb = ThisWorkbook
Dim sws As Worksheet: Set sws = wb.Worksheets("valid_package")
Dim slRow As Long: slRow = sws.Cells(sws.Rows.Count, "A").End(xlUp).Row
Dim dws As Worksheet: Set dws = wb.Worksheets("product")
Dim dlRow As Long: dlRow = dws.Cells(dws.Rows.Count, "D").End(xlUp).Row
Dim i As Long, j As Long
For i = 2 To dlRow
For j = 2 To slRow
If dws.Cells(i, "D").Value = sws.Cells(j, "A").Value Then
If dws.Cells(i, "H").Value = sws.Cells(j, "B").Value Then
dws.Cells(i, "H").Interior.Color = vbGreen
Else
dws.Cells(i, "H").Interior.Color = xlNone
End If
End If
Next j
Next i
Debug.Print "Readable: " & Timer - t
End Sub
Sub ValidationEfficient()
Dim t As Double: t = Timer
Dim wb As Workbook: Set wb = ThisWorkbook
Dim sws As Worksheet: Set sws = wb.Worksheets("valid_package")
Dim slRow As Long: slRow = sws.Cells(sws.Rows.Count, "A").End(xlUp).Row
Dim srg1 As Range: Set srg1 = sws.Range("A2:A" & slRow)
Dim srg2 As Range: Set srg2 = sws.Range("B2:B" & slRow)
Dim dws As Worksheet: Set dws = wb.Worksheets("product")
Dim dlRow As Long: dlRow = dws.Cells(dws.Rows.Count, "D").End(xlUp).Row
Dim drg1 As Range: Set drg1 = dws.Range("D2:D" & dlRow)
Dim drg2 As Range: Set drg2 = dws.Range("H2:H" & dlRow)
Dim ddrg As Range
Dim dCell As Range
Dim sIndex As Variant
Dim dr As Long
For dr = 1 To drg1.Rows.Count
sIndex = Application.Match(drg1.Cells(dr).Value, srg1, 0)
If IsNumeric(sIndex) Then
If drg2.Cells(dr).Value = srg2.Cells(sIndex).Value Then
If ddrg Is Nothing Then
Set ddrg = drg2.Cells(dr)
Else
Set ddrg = Union(ddrg, drg2.Cells(dr))
End If
End If
End If
Next dr
If Not ddrg Is Nothing Then
drg2.Interior.Color = xlNone
ddrg.Interior.Color = vbGreen
End If
Debug.Print "Efficient: " & Timer - t
End Sub
Please, test the next code. It should be fast, using Find, placing the range to be colored in a Union range and coloring it at the code end. I hope that I correctly understood what you want and mostly what you have...
Sub validation()
Dim shP As Worksheet, shVP As Worksheet, rngColor As Range, rngA As Range, rngB As Range
Dim lastRow_P As Long, lastRow_VP As Long, cellMatch As Range, i As Long
Set shP = Sheets("product")
Set shVP = Sheets("valid_package")
lastRow_P = shP.cells(rows.Count, "D").End(xlUp).row
lastRow_VP = shVP.cells(rows.Count, "A").End(xlUp).row
Set rngA = shVP.Range("A2:A" & lastRow_VP)
For i = 2 To lastRow_P
Set cellMatch = rngA.Find(what:=shP.cells(i, "D").Value, LookIn:=xlValues, Lookat:=xlWhole)
If Not cellMatch Is Nothing Then
If cellMatch.Offset(0, 1).Value = shP.cells(i, "H").Value Then
If rngColor Is Nothing Then
Set rngColor = shP.cells(i, "H")
Else
Set rngColor = Union(rngColor, shP.cells(i, "H"))
End If
End If
End If
Next i
If Not rngColor Is Nothing Then rngColor.Interior.color = vbGreen
End Sub
I am looking for a way to select an entire row but skip the first 3 columns of the same row without using 'range()' command. What command can i use?
You can use a combination of Cells and Resize:
Range.Cells Property
Range.Resize Property
Depending on how you ask the question (skip first column or first column is), you can use the combination as follows:
Option Explicit
Sub EntireSkipColumns()
Dim ws As Worksheet: Set ws = ActiveSheet
Dim rng As Range
Dim FR As Long: FR = 2
Dim LR As Long: LR = 10
Dim i As Long
Dim j As Long: j = 3 ' Skip first 3 columns
For i = FR To LR
Set rng = ws.Cells(i, j + 1).Resize(, ws.Columns.Count - j)
With rng
' To check if the range is correct.
Debug.Print .Address(False, False)
' Cycle Interior ColorIndex
'.Interior.ColorIndex = i
End With
Next i
End Sub
Sub EntireFirstColumn()
Dim ws As Worksheet: Set ws = ActiveSheet
Dim rng As Range
Dim FR As Long: FR = 2
Dim LR As Long: LR = 10
Dim i As Long
Dim j As Long: j = 4 ' Use 4 as the first column
For i = FR To LR
Set rng = ws.Cells(i, j).Resize(, ws.Columns.Count - j + 1)
With rng
' To check if the range is correct.
Debug.Print .Address(False, False)
' Cycle Interior ColorIndex
'.Interior.ColorIndex = i
End With
Next i
End Sub
EDIT:
Set rngTarget = rngTarget.Offset(1) is only used to move each result a row below.
Sub QualifyCellsToo()
Dim wsSource As Worksheet: Set wsSource = ThisWorkbook.Worksheets("Sheet1")
Dim wsTarget As Worksheet: Set wsTarget = ThisWorkbook.Worksheets("Sheet2")
Dim rngSource As Range
Dim rngTarget As Range
' This is wrong:
'Worksheets("sheets1").Range(Cells(3, 4), Cells(3, 9)).Copy _
Worksheets("sheets2").Range(Cells(3, 4), Cells(3, 9))
' You have to qualify 'Cells', too:
Worksheets("Sheet1").Range(Worksheets("Sheet1").Cells(3, 4), _
Worksheets("Sheet1").Cells(3, 9)).Copy _
Worksheets("Sheet2").Range(Worksheets("Sheet2").Cells(3, 4), _
Worksheets("Sheet2").Cells(3, 9))
' This is a long expression, so using variables is preferred.
Set rngSource = wsSource.Range(wsSource.Cells(3, 4), wsSource.Cells(3, 9))
Set rngTarget = wsTarget.Range(wsTarget.Cells(3, 4), wsTarget.Cells(3, 9))
Set rngTarget = rngTarget.Offset(1)
rngTarget.Resize(10).Clear
' Copy values or formulas and formats using same sized ranges.
rngSource.Copy rngTarget
Set rngTarget = rngTarget.Offset(1)
' Copy values or formulas and formats using only the first cell
' of Target Range.
rngSource.Copy rngTarget.Cells(1)
Set rngTarget = rngTarget.Offset(1)
' Copy values
rngTarget.Value = rngSource.Value
Set rngTarget = rngTarget.Offset(1)
' Copy values using target without '.Value'
rngTarget = rngSource.Value
Set rngTarget = rngTarget.Offset(1)
End Sub
I have data in a table, where I compare two columns J and T. The values which J and T can take include A2B, APL, BGF, CMA, among others (see code).
If these values are equal, copy row i into the sheet which has the name of the cells just checked.
If these values are not equal, copy row i into the sheets which have the name of the cells just checked.
Example: Compare J2 and T2,
Suppose J2=T2=BGF then copy row 2 and paste into sheet("BGF")
Next, compare J3 and T3
Suppose J3=BGF and T3=CMA, copy row 3 and paste into sheet(BGF) and sheet(CMA)
Next, compare J4 and T4
Suppose J4=Nothing and T4=CMA, copy row 4 and paste into sheet CMA
the only other combination is where Ji has a value and Ti is empty.
Problem: When running this code, If J3=BGF and T3= nothing (its empty), then the line is not copied to any sheet.
Here's the code
Sub Sortdata()
'step 1 clear all data
Sheets("A2B").Cells.ClearContents
Sheets("APL").Cells.ClearContents
Sheets("BGF").Cells.ClearContents
Sheets("CMA").Cells.ClearContents
Sheets("K Line").Cells.ClearContents
Sheets("MacAndrews").Cells.ClearContents
Sheets("Maersk").Cells.ClearContents
Sheets("OOCL").Cells.ClearContents
Sheets("OPDR").Cells.ClearContents
Sheets("Samskip").Cells.ClearContents
Sheets("Unifeeder").Cells.ClearContents
Dim i As Long
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim LastRow As Long
With Worksheets("All Data")
LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
For i = 2 To LastRow
If IsEmpty(.Range("J" & i)) Then
Set ws1 = Nothing
Else
Set ws1 = Worksheets(.Range("J" & i).Value)
End If
If IsEmpty(.Range("T" & i)) Then
Set ws2 = Nothing
Else
Set ws2 = Worksheets(.Range("T" & i).Value)
End If
If ws1 Is Nothing Then
If Not ws2 Is Nothing Then
CopyToWs ws2, .Rows(i)
End If
ElseIf ws2 Is Nothing Then
If Not ws1 Is Nothing Then
CopyToWs ws1, .Rows(i)
End If
Else
CopyToWs ws1, Rows(i)
If ws1.Name <> ws2.Name Then
CopyToWs ws2, .Rows(i)
End If
End If
Next
End With
End Sub
Sub CopyToWs(ws As Worksheet, rng As Range)
rng.Copy
ws.Cells(ws.Rows.Count, 1).End(xlUp).Offset(1, 0).EntireRow.PasteSpecial xlPasteValuesAndNumberFormats
End Sub
Please try this code. It takes a slightly different approach to what you tried but it gets the job done, I think.
Option Explicit
Sub Sortdata()
' Variatus #STO 20 Jan 2020
Const WsNames As String = "A2B,APL,BGF,CMA,K Line,MacAndrews," & _
"Maersk,OOCL,OPDR,Samskip,Unifeeder"
Dim WsS As Worksheet ' Source
Dim Ws As Worksheet
Dim Rng As Range
Dim Rt As Long ' target row
Dim LastRow As Long
Dim J As Long, T As Long
Dim Tmp As Variant, PrevTmp As Variant
Dim R As Long, C As Long
'step 1 clear all data
Tmp = Split(WsNames, ",")
For R = LBound(Tmp) To UBound(Tmp)
On Error Resume Next
Worksheets(Tmp(R)).Cells.ClearContents
Next R
Application.ScreenUpdating = False
Set WsS = Worksheets("All Data")
With WsS
J = .Columns("J").Column
T = .Columns("T").Column
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
For R = 2 To LastRow
PrevTmp = ""
For C = J To T Step T - J
Tmp = .Cells(R, C).Value
If Len(Tmp) And Tmp <> PrevTmp Then
On Error Resume Next
Set Ws = Worksheets(Tmp)
If Err = 0 Then
Set Rng = .Range(.Cells(R, 1), .Cells(R, .Columns.Count).End(xlToLeft))
With Ws
Rt = Application.Max(.Cells(.Rows.Count, "A").End(xlUp).Row + 1, 2)
Rng.Copy Destination:=Ws.Cells(Rt, 1)
End With
End If
End If
PrevTmp = Tmp
Next C
If R Mod 25 = 0 Then Application.StatusBar = "Currently processing row " & R
Next R
End With
With Application
.ScreenUpdating = True
.StatusBar = "Done"
End With
End Sub
I think you will be able to find your way through it and make any required modifications. Let me know if you require any assistance.