Solved Macro to move range of rows to multiple sheets using keyword

December 29, 2017 at 09:20:28
Specs: Windows 10
Hi,

I have 50 shipment details in one excel sheet. each shipment have 10 row of details and each shipment start with the heading SHIPMENT BILL. I would like to have a code to copy from cell which contains shipment bill until the cell before contains SHIPMENT BILL and move to next sheet. Likewise 50 shipment details have to move to 50 sheets. don't know what to start the coding and can anyone able to help.

Regards


See More: Macro to move range of rows to multiple sheets using keyword

Report •

✔ Best Answer
December 31, 2017 at 21:08:37
It probably depends on where you stored the code. This should work anywhere:

Sub CopyShippingDetails_v3()

'Determine Last Row to force .Find to start at top of sheet
  lastRw = Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row
  
'Determine Row of first *SHIPMENT BILL*
  With Worksheets(1).Columns(1)
     Set s = .Find("~*SHIPMENT BILL~*", _
             LookIn:=xlValues, LookAt:=xlWhole, after:=Cells(lastRw, 1))
       If Not s Is Nothing Then
        firstAddress = s.Address
        startRw = s.Row

        Do
'Determine Row of *END OF SHIPMENT BILL*
          Set e = .Find("~*END OF SHIPMENT BILL~*", _
                  LookIn:=xlValues, LookAt:=xlWhole, after:=Cells(s.Row, 1))
            endRw = e.Row
          
'Add sheet, copy Range
           Sheets.Add after:=Sheets(Sheets.Count)
            Range(Sheets(1).Cells(startRw, 1), Sheets(1).Cells(endRw, Columns.Count)).Copy _
             Sheets(Sheets.Count).Cells(1, 1)
             
'Determine Row of Next *SHIPMENT BILL*
          Set s = .Find("~*SHIPMENT BILL~*", _
             LookIn:=xlValues, LookAt:=xlWhole, after:=Cells(endRw, 1))
             startRw = s.Row
              
'Loop until all "*SHIPMENT BILL*" strings have been found
        If s Is Nothing Then
            GoTo DoneCopying
        End If
        Loop While s.Address <> firstAddress
      End If
DoneCopying:
  End With
End Sub

How To Post Data or Code ---> Click Here Before Posting Data or VBA Code



#1
December 29, 2017 at 19:31:47
The following code should get you started. As much as I hate assuming things when writing code, I made the following assumptions:

1 - The data that you want copied is in Sheet 1
2 - The search string "SHIPMENT BILL" is in Column A
3 - When you say "each shipment have 10 row of details", you mean that each Range to be copied contains 11 Rows: A row for the heading of SHIPMENT BILL and then 10 rows of details
4 - You want the pasted data to start in A1 of each new sheet

If those assumptions are correct, the following code should meet your requirements. If not, then the code will require some modifications.

Sub CopyShippingDetails()
'Assumes "SHIPMENT BILL" string is in Column A
  With Worksheets(1).Columns(1)
'Find search string
     Set s = .Find("SHIPMENT BILL", LookIn:=xlValues)
     If Not s Is Nothing Then
        firstAddress = s.Address
'Copy 11 Rows to New Sheet
        Do
            Sheets.Add After:=Sheets(Sheets.Count)
            Sheets(1).Range(Cells(s.Row, 1), Cells(s.Row + 10, Columns.Count)).Copy _
             Sheets(Sheets.Count).Cells(1, 1)
            Set s = .FindNext(s)
        If s Is Nothing Then
            GoTo DoneCopying
        End If
'Loop until all SHIPMENT BILL strings have been found
        Loop While s.Address <> firstAddress
      End If
DoneCopying:
  End With
End Sub

How To Post Data or Code ---> Click Here Before Posting Data or VBA Code


Report •

#2
December 30, 2017 at 11:57:28
Hi Derby,

Thank you very much for the coding. now I have an idea. when I run the above code, this line is not working as am getting Run time error Application defined or object defined error.

Sheets(1).Range(Cells(s.Row, 1), Cells(s.Row + 10, Columns.Count)).Copy _
Sheets(Sheets.Count).Cells(1, 1)
did I miss anything here ?

Regards


Report •

#3
December 30, 2017 at 12:22:03
Not having your exact data to work with, I have no idea if you "missed anything".

Did you try single stepping through the code to see if you can figure out what is causing that error?

I copied the line you posted and pasted in place of that line in my VBA editor, just in case there was some difference that I didn't see. Even after I did that the code worked fine for me with data that looks like the following:

	A
1  Shipment Bill
2	1
3	2
4	3
5	4
6	5
7	6
8	7
9	8
10	9
11	10
12  Shipment Bill
13	11
14	12
15	13
16	14
17	15
18	16
19	17
20	18
21	19
22	20
23  Shipment Bill
24	21
25	22
26	23
27	24
28	25
29	26
30	27
31	28
32	29
33	30

How To Post Data or Code ---> Click Here Before Posting Data or VBA Code


Report •

Related Solutions

#4
December 30, 2017 at 19:30:24
Hi Derby,

Thanks again. I have tried your data as well and when I try single stepping through the
code, I am getting the error in the same line and its happening right after the next
sheet has created.

Sorry Derby for not posting data in the first place. The below is the data am having. I
just found out that I have one more constraint that some shipment have more than
10 rows. but I have noticed that each shipment details finished with unique word
"END of SHIPMENT BILL". so can we find the top keyword and bottom keyword &
copy the whole range of rows and paste to the next sheet.

 
	A	B	C	D	E	F	G	H
1	*SHIPMENT BILL*							
2	REGIME TYPE1							
3	Import							
4	CARGO CHANNEL2	DECLARATION TYPE3		DECLARATION DATE4		REQUEST NO.5a	DECLARATION NO. / CUSTOMS CLEARANCE NO.5b	MIRSAL REFERENCE NO.
5	Courier Air	Courier Import		12/28/2017		46665528	1140756031317	
6	MAWB/MBOL11	HAWB/HBOL12		CARRIER NUMBER13		CARRIER NAME14	SCHEDULED DATE15	
7	40652230743					5X0010	12/28/2017	
8	ORIGINAL LOAD PORT16	PORT OF LOAD17		PORT OF DISCHARGE18		DESTINATION COUNTRY19		
9		Koln		 AIRPORT FREE ZONE				
10	NET WEIGHT20	GROSS WEIGHT21		MEASUREMENT22		CARGO TYPE24		
11	3.8 kg	3.8 kg				General		
12	PURPOSE41	PURPOSE DETAILS						
13	*END OF SHIPMENT BILL*							
14								
15	*SHIPMENT BILL*							
16	REGIME TYPE1							
17	Import							
18	CARGO CHANNEL2	DECLARATION TYPE3		DECLARATION DATE4		REQUEST NO.5a	DECLARATION NO. / CUSTOMS CLEARANCE NO.5b	MIRSAL REFERENCE NO.
19	Courier Air	Courier Import		12/28/2017		46665533	1140756032717	
20	MAWB/MBOL11	HAWB/HBOL12		CARRIER NUMBER13		CARRIER NAME14	SCHEDULED DATE15	
21	40652230743					5X0010	12/28/2017	
22	ORIGINAL LOAD PORT16	PORT OF LOAD17		PORT OF DISCHARGE18		DESTINATION COUNTRY19		
23		Koln		 AIRPORT FREE ZONE				
24	NET WEIGHT20	GROSS WEIGHT21		MEASUREMENT22		CARGO TYPE24		
25	0.91 kg	0.91 kg				General		
26	PURPOSE41	PURPOSE DETAILS						
27	*END OF SHIPMENT BILL							


Report •

#5
December 30, 2017 at 20:36:29
Now you see why I hate making assumptions before writing code. Not only don't you have 10 rows of data to copy, you don't have SHIPMENT BILL as your heading. *SHIPMENT BILL* is not the same thing as SHIPMENT BILL.

I rewrote the code based on the example data that you posted. You will note a couple of significant changes:

1 - The search string is now: "~*SHIPMENT BILL~*" The tildes are required because the asterisks are normally seen as wild cards by the .Find function. The tildes tell VBA to find the actual asterisks.

2 - Since your example data has an empty row row between each shipment, VBA can use the CurrentRegion property to copy each segment of data. It doesn't need to find the bottom keyword because it can use the blank row to determine the end of each segment.

BTW...I still have no idea why you are getting an error with the previous code. I don't get that error with my example data or with yours. If you get that same error with the following code, then it's something with your workbook because this code works for me, just like the previous code did.

Sub CopyShippingDetails_v2()
'Determine Last Row to force .Find to start at top of sheet
  lastRw = Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row
'Assumes "*SHIPMENT BILL*" string is in Column A
  With Worksheets(1).Columns(1)
'Find search string, starting at top of sheet
     Set s = .Find("~*SHIPMENT BILL~*", LookIn:=xlValues, _
                                        After:=Cells(lastRw, 1))
       If Not s Is Nothing Then
        firstAddress = s.Address
'Copy 11 Rows to New Sheet
        Do
            Sheets.Add After:=Sheets(Sheets.Count)
            Cells(s.Row, 1).CurrentRegion.Copy _
             Sheets(Sheets.Count).Cells(1, 1)
            Set s = .FindNext(s)
        If s Is Nothing Then
            GoTo DoneCopying
        End If
'Loop until all "*SHIPMENT BILL*" strings have been found
        Loop While s.Address <> firstAddress
      End If
DoneCopying:
  End With
End Sub

How To Post Data or Code ---> Click Here Before Posting Data or VBA Code


Report •

#6
December 30, 2017 at 21:47:11
WOW.... it works perfectly. Great thanks.
but I have one more problem that I am having empty rows in between shipment details for some shipments. so when the data copied to next sheet, its only the partial data be copying. if I have around 10 shipment, i can able to find the empty rows and delete manually, but sometime am having 50 to 100.

so, is any way to copy until last line of shipment detail?

Regards


Report •

#7
December 31, 2017 at 07:20:37
The main problem is that you keep supplying incomplete/inaccurate requirements.

Please keep in mind that we can't see your workbook from where we're sitting and we certainly can't read minds. We can can only work with what we are told and shown. With incomplete/inaccurate requirements, we end up wasting time writing code that doesn't fit your needs.

I'll see what I can do to "fix" the code based on your most recent changes.

How To Post Data or Code ---> Click Here Before Posting Data or VBA Code


Report •

#8
December 31, 2017 at 07:44:56
plz accept my apologies as am a new user and its the first time am trying with forum. Appreciate your understanding.

Regards


Report •

#9
December 31, 2017 at 08:12:39
Why did you mark the thread as solved if the code doesn't work for you? Please wait until we are done before choosing a Best Answer. I have reset your choice for the time being.

How To Post Data or Code ---> Click Here Before Posting Data or VBA Code

message edited by DerbyDad03


Report •

#10
December 31, 2017 at 10:47:28
I clicked erroneously thanks for the reset

Report •

#11
December 31, 2017 at 14:33:07
Try this version:

Sub CopyShippingDetails_v3()

'Determine Last Row to force .Find to start at top of sheet
  lastRw = Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row
  
'Determine Row of first *SHIPMENT BILL*
  With Worksheets(1).Columns(1)
     Set s = .Find("~*SHIPMENT BILL~*", _
             LookIn:=xlValues, LookAt:=xlWhole, after:=Cells(lastRw, 1))
       If Not s Is Nothing Then
        firstAddress = s.Address
        startRw = s.Row

        Do
'Determine Row of *END OF SHIPMENT BILL*
          Set e = .Find("~*END OF SHIPMENT BILL~*", _
                  LookIn:=xlValues, LookAt:=xlWhole, after:=Cells(s.Row, 1))
            endRw = e.Row
          
'Add sheet, copy Range
           Sheets.Add after:=Sheets(Sheets.Count)
            Range(Cells(startRw, 1), Cells(endRw, Columns.Count)).Copy _
             Sheets(Sheets.Count).Cells(1, 1)
             
'Determine Row of Next *SHIPMENT BILL*
          Set s = .Find("~*SHIPMENT BILL~*", _
             LookIn:=xlValues, LookAt:=xlWhole, after:=Cells(endRw, 1))
             startRw = s.Row
              
'Loop until all "*SHIPMENT BILL*" strings have been found
        If s Is Nothing Then
            GoTo DoneCopying
        End If
        Loop While s.Address <> firstAddress
      End If
DoneCopying:
  End With
End Sub

How To Post Data or Code ---> Click Here Before Posting Data or VBA Code


Report •

#12
December 31, 2017 at 20:27:53
Thanks Derby. I have tried single stepping through the code and no errors in the code at all.

but data is not copying to the sheets. what I have found is that if there is 10 shipment, 10 new sheets are creating automatically with no data.

I though I have a problem with my data so I have tried with the dummy value but still sheets creating with empty data. do I need to add anything in the code?

	
               A
1	*SHIPMENT BILL*
2	A
3	B
4	
5	D
6	E
7	*END OF SHIPMENT BILL*
8	
9	*SHIPMENT BILL*
10	A
11	B
12	
13	D
14	E
15	*END OF SHIPMENT BILL*
16	
17	*SHIPMENT BILL*
18	A
19	B
20	
21	D
22	E
23	*END OF SHIPMENT BILL*


Regards


Report •

#13
December 31, 2017 at 21:08:37
✔ Best Answer
It probably depends on where you stored the code. This should work anywhere:

Sub CopyShippingDetails_v3()

'Determine Last Row to force .Find to start at top of sheet
  lastRw = Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row
  
'Determine Row of first *SHIPMENT BILL*
  With Worksheets(1).Columns(1)
     Set s = .Find("~*SHIPMENT BILL~*", _
             LookIn:=xlValues, LookAt:=xlWhole, after:=Cells(lastRw, 1))
       If Not s Is Nothing Then
        firstAddress = s.Address
        startRw = s.Row

        Do
'Determine Row of *END OF SHIPMENT BILL*
          Set e = .Find("~*END OF SHIPMENT BILL~*", _
                  LookIn:=xlValues, LookAt:=xlWhole, after:=Cells(s.Row, 1))
            endRw = e.Row
          
'Add sheet, copy Range
           Sheets.Add after:=Sheets(Sheets.Count)
            Range(Sheets(1).Cells(startRw, 1), Sheets(1).Cells(endRw, Columns.Count)).Copy _
             Sheets(Sheets.Count).Cells(1, 1)
             
'Determine Row of Next *SHIPMENT BILL*
          Set s = .Find("~*SHIPMENT BILL~*", _
             LookIn:=xlValues, LookAt:=xlWhole, after:=Cells(endRw, 1))
             startRw = s.Row
              
'Loop until all "*SHIPMENT BILL*" strings have been found
        If s Is Nothing Then
            GoTo DoneCopying
        End If
        Loop While s.Address <> firstAddress
      End If
DoneCopying:
  End With
End Sub

How To Post Data or Code ---> Click Here Before Posting Data or VBA Code


Report •

#14
December 31, 2017 at 21:27:31
Thanks for all your support Derby. The above code works perfectly without any error. its amazing.

Wish you happy new year !!!

Regards


Report •

#15
January 1, 2018 at 05:28:22

Report •

Ask Question