PDA

View Full Version : Split certain cells to multiple sheets IF value



aurelius142
02-08-2016, 07:26 AM
Hi there,

I am trying to make an Excel which automatically split certain cell information throughout multiple sheets based on a cell value. I am not an expert at all with VBA, so I am still learning a lot by checking out other codes.

I have found the code below on the internet and adjusted it a bit.

The code now does automatically split the information to certain cells, however I cannot seem to make it work to split the information to multiple cells:
Split A to sheet3 (sheetname: Info)
Split B to sheet4 (sheetname: Details)
Split C to sheet 5 (sheetname: Prices)

Also I would like to change the sheet1 (the source) to change to sheet2, but if I adjust sheet 1 to sheet 2 the code gives me an error.

I have tried to change Sheet1 to Sheet2 and I also tried to change “Sheet2” to “Info”.
I’ve have also tried to change the Sheet2 at the ElseIf “B” to “Sheet3” and
ElseIf “C” to “Sheet4” but that did not work.


Can someone explain me how I could make it work? Thanks in advance.

Below is the code I use.



Sub copycolumns()
Dim lastrow As Long, erow As Long

lastrow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To lastrow
If Sheet1.Cells(i, 3) = "A" Then
Sheet1.Cells(i, 2).Copy
erow = Sheet2.Cells(Rows.Count, 2).End(xlUp).Offset(1, 0).Row

Sheet1.Paste Destination:=Worksheets(“Sheet2").Cells(erow, 2)

Sheet1.Cells(i, 1).Copy
Sheet1.Paste Destination:=Worksheets("Sheet2").Cells(erow, 3)

Sheet1.Cells(i, 11).Copy
Sheet1.Paste Destination:=Worksheets("Sheet2").Cells(erow, 5)

Sheet1.Cells(i, 4).Copy
Sheet1.Paste Destination:=Worksheets("Sheet2").Cells(erow, 6)

Sheet1.Cells(i, 12).Copy
Sheet1.Paste Destination:=Worksheets("Sheet2").Cells(erow, 7)

Sheet1.Cells(i, 9).Copy
Sheet1.Paste Destination:=Worksheets("Sheet2").Cells(erow, 9)

Sheet1.Cells(i, 10).Copy
Sheet1.Paste Destination:=Worksheets("Sheet2").Cells(erow, 10)

ElseIf Sheet1.Cells(i, 3) = "B" Then
Sheet1.Cells(i, 2).Copy
erow = Sheet2.Cells(Rows.Count, 2).End(xlUp).Offset(1, 0).Row

Sheet1.Paste Destination:=Worksheets("Sheet2").Cells(erow, 2)

Sheet1.Cells(i, 1).Copy
Sheet1.Paste Destination:=Worksheets("Sheet2").Cells(erow, 3)

Sheet1.Cells(i, 11).Copy
Sheet1.Paste Destination:=Worksheets("Sheet2").Cells(erow, 5)

ElseIf Sheet1.Cells(i, 3) = "C" Then
Sheet1.Cells(i, 2).Copy
erow = Sheet2.Cells(Rows.Count, 2).End(xlUp).Offset(1, 0).Row

Sheet1.Paste Destination:=Worksheets("Sheet2").Cells(erow, 2)

Sheet1.Cells(i, 4).Copy
Sheet1.Paste Destination:=Worksheets("Sheet2").Cells(erow, 6)

Sheet1.Cells(i, 12).Copy
Sheet1.Paste Destination:=Worksheets("Sheet2").Cells(erow, 7)

Sheet1.Cells(i, 9).Copy
Sheet1.Paste Destination:=Worksheets("Sheet2").Cells(erow, 9)
End If
Next i

Application.CutCopyMode = False
Sheet2.Columns.AutoFit
Range("A1").Select


End Sub

mancubus
02-08-2016, 08:09 AM
welcome to vbax.

try below with a copy of your file.


Sub vbax_55078_Split_Table_Based_On_Col_Value() Dim LastRow As Long

With Worksheets("SourceSheetNameHere")
.AutoFilterMode = False

LastRow = Worksheets("Info").Cells(Rows.Count, 1).End(xlUp).Row
.Cells(1).AutoFilter Field:=3, Criteria1:="=A"
.UsedRange.Columns(2).Offset(1).SpecialCells(12).Copy Destination:=Worksheets("Info").Cells(LastRow, 2)
.UsedRange.Columns(1).Offset(1).SpecialCells(12).Copy Destination:=Worksheets("Info").Cells(LastRow, 3)
.UsedRange.Columns(11).Offset(1).SpecialCells(12).Copy Destination:=Worksheets("Info").Cells(LastRow, 5)
.UsedRange.Columns(4).Offset(1).SpecialCells(12).Copy Destination:=Worksheets("Info").Cells(LastRow, 6)
.UsedRange.Columns(12).Offset(1).SpecialCells(12).Copy Destination:=Worksheets("Info").Cells(LastRow, 7)
.UsedRange.Columns(9).Offset(1).SpecialCells(12).Copy Destination:=Worksheets("Info").Cells(LastRow, 9)
.UsedRange.Columns(10).Offset(1).SpecialCells(12).Copy Destination:=Worksheets("Info").Cells(LastRow, 10)

LastRow = Worksheets("Details").Cells(Rows.Count, 1).End(xlUp).Row
.Cells(1).AutoFilter Field:=3, Criteria1:="=B"
.UsedRange.Columns(2).Offset(1).SpecialCells(12).Copy Destination:=Worksheets("Details").Cells(LastRow, 2)
.UsedRange.Columns(1).Offset(1).SpecialCells(12).Copy Destination:=Worksheets("Details").Cells(LastRow, 3)
.UsedRange.Columns(11).Offset(1).SpecialCells(12).Copy Destination:=Worksheets("Details").Cells(LastRow, 5)

LastRow = Worksheets("Prices").Cells(Rows.Count, 1).End(xlUp).Row
.Cells(1).AutoFilter Field:=3, Criteria1:="=C"
.UsedRange.Columns(2).Offset(1).SpecialCells(12).Copy Destination:=Worksheets("Prices").Cells(LastRow, 2)
.UsedRange.Columns(4).Offset(1).SpecialCells(12).Copy Destination:=Worksheets("Prices").Cells(LastRow, 6)
.UsedRange.Columns(12).Offset(1).SpecialCells(12).Copy Destination:=Worksheets("Prices").Cells(LastRow, 7)
.UsedRange.Columns(9).Offset(1).SpecialCells(12).Copy Destination:=Worksheets("Prices").Cells(LastRow, 9)

.AutoFilterMode = False
End With

End Sub

aurelius142
02-08-2016, 10:03 AM
welcome to vbax.

try below with a copy of your file.


Sub vbax_55078_Split_Table_Based_On_Col_Value() Dim LastRow As Long

With Worksheets("SourceSheetNameHere")
.AutoFilterMode = False

LastRow = Worksheets("Info").Cells(Rows.Count, 1).End(xlUp).Row
.Cells(1).AutoFilter Field:=3, Criteria1:="=A"
.UsedRange.Columns(2).Offset(1).SpecialCells(12).Copy Destination:=Worksheets("Info").Cells(LastRow, 2)
.UsedRange.Columns(1).Offset(1).SpecialCells(12).Copy Destination:=Worksheets("Info").Cells(LastRow, 3)
.UsedRange.Columns(11).Offset(1).SpecialCells(12).Copy Destination:=Worksheets("Info").Cells(LastRow, 5)
.UsedRange.Columns(4).Offset(1).SpecialCells(12).Copy Destination:=Worksheets("Info").Cells(LastRow, 6)
.UsedRange.Columns(12).Offset(1).SpecialCells(12).Copy Destination:=Worksheets("Info").Cells(LastRow, 7)
.UsedRange.Columns(9).Offset(1).SpecialCells(12).Copy Destination:=Worksheets("Info").Cells(LastRow, 9)
.UsedRange.Columns(10).Offset(1).SpecialCells(12).Copy Destination:=Worksheets("Info").Cells(LastRow, 10)

LastRow = Worksheets("Details").Cells(Rows.Count, 1).End(xlUp).Row
.Cells(1).AutoFilter Field:=3, Criteria1:="=B"
.UsedRange.Columns(2).Offset(1).SpecialCells(12).Copy Destination:=Worksheets("Details").Cells(LastRow, 2)
.UsedRange.Columns(1).Offset(1).SpecialCells(12).Copy Destination:=Worksheets("Details").Cells(LastRow, 3)
.UsedRange.Columns(11).Offset(1).SpecialCells(12).Copy Destination:=Worksheets("Details").Cells(LastRow, 5)

LastRow = Worksheets("Prices").Cells(Rows.Count, 1).End(xlUp).Row
.Cells(1).AutoFilter Field:=3, Criteria1:="=C"
.UsedRange.Columns(2).Offset(1).SpecialCells(12).Copy Destination:=Worksheets("Prices").Cells(LastRow, 2)
.UsedRange.Columns(4).Offset(1).SpecialCells(12).Copy Destination:=Worksheets("Prices").Cells(LastRow, 6)
.UsedRange.Columns(12).Offset(1).SpecialCells(12).Copy Destination:=Worksheets("Prices").Cells(LastRow, 7)
.UsedRange.Columns(9).Offset(1).SpecialCells(12).Copy Destination:=Worksheets("Prices").Cells(LastRow, 9)

.AutoFilterMode = False
End With

End Sub


Thanks for the help! It is almost working as I imagined.
I had two questions remaining, but (I think) I managed to fix it. Could you check if the way below is the right way to solve this?:
-The information on the "source sheet" starts at row 5, so how can I apply the filter on the 5th row instead of the 1st? (managed to fix this by adding: "If Not .AutoFilterMode Then
.Range("2:2").AutoFilter
End If"
-The information on the "other sheets" have to be pasted starting from the 2nd row. Since the first row has some titles. (managed to fix this by adding: "Rows.Count, 2).End(xlUp).Offset(1, 0).Row")

mancubus
02-08-2016, 01:47 PM
you are welcome.

please dont quote the previous posts as a whole.


change

LastRow = Worksheets("Info").Cells(Rows.Count, 1).End(xlUp).Row
to

LastRow = Worksheets("Info").Cells(Rows.Count, 1).End(xlUp).Offset(1).Row
or

LastRow = Worksheets("Info").Cells(Rows.Count, 1).End(xlUp).Row + 1
in the code i posted.

if you know the row number is always 2, you dont need a variable. just replace all the 'LastRow's with 2.



if your table in source sheet does not start at cell A1, it is an indication of poor worksheet design. delete the rows above the table where applicable.

if not, assuming table starts at A5, you can replace .Cells(1) with .Range("A5") or .Cells(5,1)



Sub vbax_55078_Split_Table_Based_On_Col_Value()

With Worksheets("SourceSheetNameHere")
.AutoFilterMode = False

.Cells(5, 1).AutoFilter Field:=3, Criteria1:="=A"
.UsedRange.Columns(2).Offset(1).SpecialCells(12).Copy Destination:=Worksheets("Info").Cells(2, 2)
.UsedRange.Columns(1).Offset(1).SpecialCells(12).Copy Destination:=Worksheets("Info").Cells(2, 3)
.UsedRange.Columns(11).Offset(1).SpecialCells(12).Copy Destination:=Worksheets("Info").Cells(2, 5)
.UsedRange.Columns(4).Offset(1).SpecialCells(12).Copy Destination:=Worksheets("Info").Cells(2, 6)
.UsedRange.Columns(12).Offset(1).SpecialCells(12).Copy Destination:=Worksheets("Info").Cells(2, 7)
.UsedRange.Columns(9).Offset(1).SpecialCells(12).Copy Destination:=Worksheets("Info").Cells(2, 9)
.UsedRange.Columns(10).Offset(1).SpecialCells(12).Copy Destination:=Worksheets("Info").Cells(2, 10)

.Cells(5, 1).AutoFilter Field:=3, Criteria1:="=B"
.UsedRange.Columns(2).Offset(1).SpecialCells(12).Copy Destination:=Worksheets("Details").Cells(2, 2)
.UsedRange.Columns(1).Offset(1).SpecialCells(12).Copy Destination:=Worksheets("Details").Cells(2, 3)
.UsedRange.Columns(11).Offset(1).SpecialCells(12).Copy Destination:=Worksheets("Details").Cells(2, 5)

.Cells(5, 1).AutoFilter Field:=3, Criteria1:="=C"
.UsedRange.Columns(2).Offset(1).SpecialCells(12).Copy Destination:=Worksheets("Prices").Cells(2, 2)
.UsedRange.Columns(4).Offset(1).SpecialCells(12).Copy Destination:=Worksheets("Prices").Cells(2, 6)
.UsedRange.Columns(12).Offset(1).SpecialCells(12).Copy Destination:=Worksheets("Prices").Cells(2, 7)
.UsedRange.Columns(9).Offset(1).SpecialCells(12).Copy Destination:=Worksheets("Prices").Cells(2, 9)

.AutoFilterMode = False
End With

End Sub

aurelius142
02-08-2016, 02:53 PM
Thank you so much for your help mancubus. It works now like I hoped it would =)

xl_xl
02-08-2016, 03:02 PM
...........

mancubus
02-08-2016, 03:06 PM
you are welcome.

i posted a solution considering you are a beginner.

if i were assigned this task, i would code it like:


Sub vbax_55078_Split_Table_Based_On_Col_Value_v2()

Dim CritDestSheetArr, SourceDestCols
Dim i As Long, j As Long

CritDestSheetArr = [{"=A", "Info"; "=B", "Details"; "=C", "Prices"}]

With Worksheets("SourceSheetNameHere")
.AutoFilterMode = False

For i = LBound(CritDestSheetArr, 1) To UBound(CritDestSheetArr, 1)
SourceDestCols = Evaluate(Choose(i, "{2,2;1,3;11,5;4,6;12,7;9,9;10,10}", "{2,2;1,3;11,5}", "{2,2;4,6;12,7;9,9}"))
.Cells(5, 1).AutoFilter Field:=3, Criteria1:=CritDestSheetArr(i, 1)
For j = LBound(SourceDestCols, 1) To UBound(SourceDestCols, 1)
.UsedRange.Columns(SourceDestCols(j, 1)).Offset(1).SpecialCells(12).Copy Destination:=Worksheets(CritDestSheetArr(i, 2)).Cells(2, SourceDestCols(j, 2))
Next j
Next i

.AutoFilterMode = False
End With

End Sub


i recommend practicing arrays, powerful evaluate function and a real life saver choose function.

mancubus
02-08-2016, 03:08 PM
and you can test the above code by displaying the changing values in a message box:



Sub vbax_55078_test()

Dim CritDestSheetArr, SourceDestCols
Dim i As Long, j As Long
Dim msg As String

CritDestSheetArr = [{"=A", "Info"; "=B", "Details"; "=C", "Prices"}]
msg = "Crit" & vbTab & "Step" & vbTab & "From" & vbTab & "Col" & vbTab & "To" & vbTab & "Col"

For i = LBound(CritDestSheetArr, 1) To UBound(CritDestSheetArr, 1)
SourceDestCols = Evaluate(Choose(i, "{2,2;1,3;11,5;4,6;12,7;9,9;10,10}", "{2,2;1,3;11,5}", "{2,2;4,6;12,7;9,9}"))
For j = LBound(SourceDestCols, 1) To UBound(SourceDestCols, 1)
msg = msg & vbLf & CritDestSheetArr(i, 1) & vbTab & j & vbTab & "Source" & vbTab & SourceDestCols(j, 1) & vbTab & CritDestSheetArr(i, 2) & vbTab & SourceDestCols(j, 2)
Next j
Next i

MsgBox msg
End Sub

aurelius142
02-08-2016, 03:16 PM
Yeah for now I am just trying to make things work. Later on, when I have more knowledge I will have to start improving my codes etc. Will play around in the future with the code above.