How to copy the same Data to another sheet. VBA Help

P

punnipah

Board Regular
Joined
Nov 3, 2021
Messages
134
Office Version
  1. 2019
Platform
  1. Windows
Hi,

I want to copy the same data to another sheet.
Ex :
1. find the same word Columns "A" have the same name "Party Code : <MARXL>" and Party Code : <POLXL>
2. Copy the same data to the new Add sheet, including the header.

DMSTP.xlsx
ABCDEFGH
1No.No.Debt TypeBARegister DateMobile. No.Mobile. Status.Mobile. Status. Date.
2Party Code : <MARXL>Assign Date : 12/05/2023Unassign Date : 12/06/2023Company Code : AWN
3
4166050020AAA3331235678927/12/2022XXXXTerminate20/04/2023
566050020AAA3331235678927/12/2022Terminate20/04/2023
6266050020AAA3331235678921/11/2022XXXXTerminate20/04/2023
766050020AAA3331235678921/11/2022Terminate20/04/2023
8366050020AAA3331235678931/10/2022XXXXTerminate25/04/2023
966050020AAA3331235678931/10/2022Terminate25/04/2023
10466050020AAA3331235678923/09/2022XXXXTerminate20/04/2023
11....................
12 Total RegionXL 8
13....................
14Party Code : <MARXL>Assign Date : 12/05/2023Unassign Date : 12/06/2023Company Code : AWN
15
16166050020AAA3331235678925/12/2022XXXXTerminate20/04/2023
1766050020AAA3331235678925/12/2022Terminate20/04/2023
18266050020AAA3331235678901/12/2022XXXXTerminate20/04/2023
1966050020AAA3331235678901/12/2022Terminate20/04/2023
20....................
21 Total RegionXU 6
22....................
23 Total Assign66050020 84
24....................
25 Total PartyMAR 301
26....................
27Party Code : <POLXL>Assign Date : 12/05/2023Unassign Date : 12/06/2023Company Code : AWN
28
29166050020AWNCU00661235678907/01/2023XXXXTerminate25/04/2023
3066050020AWNCU00661235678907/01/2023Terminate25/04/2023
31....................
32 Total RegionXL 13
33....................
34Party Code : <POLXL>Assign Date : 12/05/2023Unassign Date : 12/06/2023Company Code : AWN
35
36166050020AAA3331235678910/01/2023XXXXTerminate25/04/2023
3766050020AAA3331235678910/01/2023Terminate25/04/2023
38266050020AAA3331235678928/12/2022XXXXTerminate20/04/2023
3966050020AAA3331235678928/12/2022Terminate20/04/2023
40366050020AAA3331235678926/12/2022XXXXTerminate20/04/2023
4166050020AAA3331235678926/12/2022Terminate20/04/2023
42....................
43 Total RegionXU 14
44....................
45 Total Assign66050020 101
46....................
47 Total PartyPOL 338
48
49
Sheet1




Out put : i want to this

1687153927371.png



1687153949020.png
 

Excel Facts

Ambidextrous Undo
Undo last command with Ctrl+Z or Alt+Backspace. If you use the Undo icon in the QAT, open the drop-down arrow to undo up to 100 steps.
Sort by date Sort by votes
Book3
ABCDEFGH
1No.No.Debt TypeBARegister DateMobile. No.Mobile. Status.Mobile. Status. Date.
2Party Code : <MARXL>Assign Date : 12/05/2023Unassign Date : 12/06/2023Company Code : AWN
3
4166050020AAA3331235678927/12/2022XXXXTerminate20/04/2023
566050020AAA3331235678927/12/2022Terminate20/04/2023
6266050020AAA3331235678921/11/2022XXXXTerminate20/04/2023
766050020AAA3331235678921/11/2022Terminate20/04/2023
8366050020AAA3331235678931/10/2022XXXXTerminate25/04/2023
966050020AAA3331235678931/10/2022Terminate25/04/2023
10466050020AAA3331235678923/09/2022XXXXTerminate20/04/2023
11....................
12 Total RegionXL 8
13....................
14Party Code : <MARXL>Assign Date : 12/05/2023Unassign Date : 12/06/2023Company Code : AWN
15
16166050020AAA3331235678925/12/2022XXXXTerminate20/04/2023
1766050020AAA3331235678925/12/2022Terminate20/04/2023
18266050020AAA333123567891/12/2022XXXXTerminate20/04/2023
1966050020AAA333123567891/12/2022Terminate20/04/2023
20....................
21 Total RegionXU 6
22....................
23 Total Assign66050020 84
24....................
25 Total PartyMAR 301
MAR


Book3
ABCDEFGH
1No.No.Debt TypeBARegister DateMobile. No.Mobile. Status.Mobile. Status. Date.
2Party Code : <POLXL>Assign Date : 12/05/2023Unassign Date : 12/06/2023Company Code : AWN
3
4166050020AWNCU0066123567897/1/2023XXXXTerminate25/04/2023
566050020AWNCU0066123567897/1/2023Terminate25/04/2023
6....................
7 Total RegionXL 13
8....................
9Party Code : <POLXL>Assign Date : 12/05/2023Unassign Date : 12/06/2023Company Code : AWN
10
11166050020AAA3331235678910/1/2023XXXXTerminate25/04/2023
1266050020AAA3331235678910/1/2023Terminate25/04/2023
13266050020AAA3331235678928/12/2022XXXXTerminate20/04/2023
1466050020AAA3331235678928/12/2022Terminate20/04/2023
15366050020AAA3331235678926/12/2022XXXXTerminate20/04/2023
1666050020AAA3331235678926/12/2022Terminate20/04/2023
17....................
18 Total RegionXU 14
19....................
20 Total Assign66050020 101
21....................
22 Total PartyPOL 338
POL


Hi, While waiting for other gurus, will share my reference here.

Should be able to shorten the code even more

VBA Code: 
Option Explicit
Sub CopyData()
Dim c As Range
Dim shtname, firstaddress As String
Dim ws As Worksheet
Dim ss As Range
Dim b, k, i, row2, row1 As Integer
On Error Resume Next

Application.ScreenUpdating = False

Set ws = ThisWorkbook.Sheets("Sheet1")

With ws.Range("a1:h2500")

    'Sort Out Party Code to Column K Helper
    For Each ss In .Range("a2:a" & .Cells(Rows.Count, "A").End(xlUp).Row)
        If InStr(ss.Value, "Party") >= 1 Then
                b = b + 1
                .Cells(b, "k").Value = ss.Value
        End If
    Next ss
    .Range("k:k").RemoveDuplicates Columns:=1
    k = .Range("k1:K" & .Cells(Rows.Count, "K").End(xlUp).Row).Value
 
 
    'Loop through Each Party Code in Column K
    For i = 1 To UBound(k, 1)

    shtname = Mid(k(i, 1), 15, 3) 'Define Party Code shortname MAR/POL
 
    row2 = .Range("d1:d2500").Find(shtname, LookIn:=xlValues).Row 'Find BA Mar/POL Located Row

  Set c = .Find(k(i, 1), LookIn:=xlValues, LookAt:=xlWhole)
        If Not c Is Nothing Then
            row1 = c.Row
            firstaddress = c.Address
        
            Do
                If c.Row > row1 Then
                  Sheets.Add(after:=Sheets(Sheets.Count)).Name = shtname
                  ws.Range("a1:H1").Copy Sheets(shtname).Range("a1")
                  ws.Range(.Cells(row1, "a"), .Cells(row2, "h")).Copy Sheets(shtname).Range("a2")
                End If
    
            Set c = .FindNext(c)
            Loop While Not c Is Nothing And c.Address <> firstaddress
        End If

Next i

.Range("k:k").Clear
Application.ScreenUpdating = True
ws.Select
End With


End Sub
 
Last edited:
Upvote 0
RudRud said:
Book3
ABCDEFGH
1No.No.Debt TypeBARegister DateMobile. No.Mobile. Status.Mobile. Status. Date.
2Party Code : <MARXL>Assign Date : 12/05/2023Unassign Date : 12/06/2023Company Code : AWN
3
4166050020AAA3331235678927/12/2022XXXXTerminate20/04/2023
566050020AAA3331235678927/12/2022Terminate20/04/2023
6266050020AAA3331235678921/11/2022XXXXTerminate20/04/2023
766050020AAA3331235678921/11/2022Terminate20/04/2023
8366050020AAA3331235678931/10/2022XXXXTerminate25/04/2023
966050020AAA3331235678931/10/2022Terminate25/04/2023
10466050020AAA3331235678923/09/2022XXXXTerminate20/04/2023
11....................
12 Total RegionXL 8
13....................
14Party Code : <MARXL>Assign Date : 12/05/2023Unassign Date : 12/06/2023Company Code : AWN
15
16166050020AAA3331235678925/12/2022XXXXTerminate20/04/2023
1766050020AAA3331235678925/12/2022Terminate20/04/2023
18266050020AAA333123567891/12/2022XXXXTerminate20/04/2023
1966050020AAA333123567891/12/2022Terminate20/04/2023
20....................
21 Total RegionXU 6
22....................
23 Total Assign66050020 84
24....................
25 Total PartyMAR 301
MAR


Book3
ABCDEFGH
1No.No.Debt TypeBARegister DateMobile. No.Mobile. Status.Mobile. Status. Date.
2Party Code : <POLXL>Assign Date : 12/05/2023Unassign Date : 12/06/2023Company Code : AWN
3
4166050020AWNCU0066123567897/1/2023XXXXTerminate25/04/2023
566050020AWNCU0066123567897/1/2023Terminate25/04/2023
6....................
7 Total RegionXL 13
8....................
9Party Code : <POLXL>Assign Date : 12/05/2023Unassign Date : 12/06/2023Company Code : AWN
10
11166050020AAA3331235678910/1/2023XXXXTerminate25/04/2023
1266050020AAA3331235678910/1/2023Terminate25/04/2023
13266050020AAA3331235678928/12/2022XXXXTerminate20/04/2023
1466050020AAA3331235678928/12/2022Terminate20/04/2023
15366050020AAA3331235678926/12/2022XXXXTerminate20/04/2023
1666050020AAA3331235678926/12/2022Terminate20/04/2023
17....................
18 Total RegionXU 14
19....................
20 Total Assign66050020 101
21....................
22 Total PartyPOL 338
POL


Hi, While waiting for other gurus, will share my reference here.

Should be able to shorten the code even more

VBA Code: 
Option Explicit
Sub CopyData()
Dim c As Range
Dim shtname, firstaddress As String
Dim ws As Worksheet
Dim ss As Range
Dim b, k, i, row2, row1 As Integer
On Error Resume Next

Application.ScreenUpdating = False

Set ws = ThisWorkbook.Sheets("Sheet1")

With ws.Range("a1:h2500")

    'Sort Out Party Code to Column K Helper
    For Each ss In .Range("a2:a" & .Cells(Rows.Count, "A").End(xlUp).Row)
        If InStr(ss.Value, "Party") >= 1 Then
                b = b + 1
                .Cells(b, "k").Value = ss.Value
        End If
    Next ss
    .Range("k:k").RemoveDuplicates Columns:=1
    k = .Range("k1:K" & .Cells(Rows.Count, "K").End(xlUp).Row).Value
 
 
    'Loop through Each Party Code in Column K
    For i = 1 To UBound(k, 1)

    shtname = Mid(k(i, 1), 15, 3) 'Define Party Code shortname MAR/POL
 
    row2 = .Range("d1:d2500").Find(shtname, LookIn:=xlValues).Row 'Find BA Mar/POL Located Row

  Set c = .Find(k(i, 1), LookIn:=xlValues, LookAt:=xlWhole)
        If Not c Is Nothing Then
            row1 = c.Row
            firstaddress = c.Address
       
            Do
                If c.Row > row1 Then
                  Sheets.Add(after:=Sheets(Sheets.Count)).Name = shtname
                  ws.Range("a1:H1").Copy Sheets(shtname).Range("a1")
                  ws.Range(.Cells(row1, "a"), .Cells(row2, "h")).Copy Sheets(shtname).Range("a2")
                End If
   
            Set c = .FindNext(c)
            Loop While Not c Is Nothing And c.Address <> firstaddress
        End If

Next i

.Range("k:k").Clear
Application.ScreenUpdating = True
ws.Select
End With


End Sub
Click to expand...
Thank you Very much

i type this already But it work is incorrect
1. why Generate many sheets ?

2. if when i have more data (MAR/POL/SU/POU/POG/AUP/SO/WOP what should i do (I apologize for not providing complete information)

1687175263003.png
 
Upvote 0
VBA Code: 
Sub CopyData()
Dim c As Range
Dim shtname, firstaddress As String
Dim ws, sht As Worksheet
Dim ss As Range
Dim k As Variant
Dim b, i, row2, row1 As Integer
'Dim dict As Dictionary
Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")

On Error Resume Next

Application.ScreenUpdating = False

For Each sht In ThisWorkbook.Worksheets
    dict.Add sht.Name, ""
Next sht

Set ws = ThisWorkbook.Sheets("Sheet1")

With ws.Range("a1:h2500")

    'Sort Out Party Code to Column K Helper
    For Each ss In .Range("a2:a" & .Cells(Rows.Count, "A").End(xlUp).Row)
        If InStr(ss.Value, "Party") >= 1 Then
                b = b + 1
                .Cells(b, "k").Value = ss.Value
        End If
    Next ss
    .Range("k:k").RemoveDuplicates Columns:=1
    k = .Range("k1:K" & .Cells(Rows.Count, "K").End(xlUp).Row).Value
 
 
    'Loop through Each Party Code in Column K
    For i = 1 To UBound(k, 1)

    shtname = Mid(k(i, 1), InStr(k(i, 1), "<") + 1, 3) 'Define Party Code shortname MAR/POL
    
    If Not dict.Exists(shtname) Then
 
    row2 = .Range("d1:d2500").Find(shtname, LookIn:=xlValues).Row 'Find BA Mar/POL Located Row

  Set c = .Find(k(i, 1), LookIn:=xlValues, LookAt:=xlWhole)
        If Not c Is Nothing Then
            row1 = c.Row
            firstaddress = c.Address
        
            Do
                If c.Row > row1 Then
                  Sheets.Add(after:=Sheets(Sheets.Count)).Name = shtname
                  ws.Range("a1:H1").Copy Sheets(shtname).Range("a1")
                  ws.Range(.Cells(row1, "a"), .Cells(row2, "h")).Copy Sheets(shtname).Range("a2")
                End If
    
            Set c = .FindNext(c)
            Loop While Not c Is Nothing And c.Address <> firstaddress
        End If
    
    End If

Next i

.Range("k:k").Clear
Application.ScreenUpdating = True
ws.Select
End With


End Sub

Hi, Try this instead.

For SO/SU two digits, how's the full text looks like? It would be good if got example to track :)
 
Upvote 0
You must log in or register to reply here.

Similar threads

L
  • Solved
Help Please
2 3
Replies
21
Views
486
Asbestos_Jen
Asbestos_Jen
D
  • Question Question
Formula help needed for working with days and times.
Replies
0
Views
316
dshtesy
D
V
  • Question Question
US/European Date Format Updates Not Working on Macro Run
Replies
0
Views
104
vancher19
V
R
  • Solved
Age Group Ranging by gender
Replies
2
Views
259
Raj1979
R
sharky12345
  • Solved
Issue trying to identify earliest date & time
2
Replies
15
Views
526
sharky12345
sharky12345

Forum statistics

Threads
1,223,886
Messages
6,175,196
Members
452,616
Latest member
intern444

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top