Results 1 to 105 of 105

split Tables into multiple Tables for multiple sheets with different structure & arranging

Threaded View

  1. #4
    Forum Expert
    Join Date
    05-05-2015
    Location
    UK
    MS-Off Ver
    Microsoft Excel for Microsoft 365 MSO (Version 2402 Build 16.0.17328.20068) 64-bit
    Posts
    31,523

    Re: split Tables into multiple Tables for multiple sheets with different structure & arran

    Public OriginRng As Range, BrandRng As Range
    Sub Copy2Sheets()
    
        Dim src As Worksheet
        Dim trg As Worksheet
        Dim LastRow As Long, rcount As Long, srow As Long, lrow As Long
        
        Application.ScreenUpdating = False
            
        
        
        Set src = ThisWorkbook.Worksheets("tt")
        
        srow = 2
        
        With src
        
            .Activate
        
            LastRow = .Cells(Rows.Count, "A").End(xlUp).Row
            Set srcRng = .Range("A1:A" & LastRow)
            shtname = .Cells(srow, "A")                          ' First sheet
            
            rcount = WorksheetFunction.CountIf(srcRng, shtname)
            lrow = srow + rcount - 1
            
            Set trg = ThisWorkbook.Worksheets(shtname)
            hdr = Array("Item", "Brand", "Origin", "Qty")
            
            trg.Range("A1").Resize(1, 4) = hdr
            .Range("H" & srow & ":H" & lrow).Copy Destination:=trg.Range("A2")
            .Range("E" & srow & ":E" & lrow).Copy Destination:=trg.Range("B2")
            .Range("C" & srow & ":C" & lrow).Copy Destination:=trg.Range("C2")
            .Range("B" & srow & ":B" & lrow).Copy Destination:=trg.Range("D2")
            
            Set BrandRng = trg.Range("B2:B" & rcount + 1)
            Set OriginRng = trg.Range("C2:C" & rcount + 1)
            Call Get_Origin
            
            '************************************************************************
            hdr = Array("Sr", "Item Code", "Accepted Quantity")
            
            srow = lrow + 1
            shtname = .Cells(srow, "A")                         ' Second sheet
            srow = srow + 1
            rcount = WorksheetFunction.CountIf(srcRng, shtname) - 1
            lrow = srow + rcount - 1
            
            Set trg = ThisWorkbook.Worksheets(shtname)
             
             trg.Range("A1").Resize(1, 3) = hdr
            .Range("B" & srow & ":B" & lrow).Copy Destination:=trg.Range("A2")
            .Range("C" & srow & ":C" & lrow).Copy Destination:=trg.Range("B2")
            .Range("F" & srow & ":F" & lrow).Copy Destination:=trg.Range("C2")
            
            For i = 1 To rcount
                 trg.Range("B" & i + 1) = trg.Range("B" & i + 1) & " JAP"
                 trg.Range("C" & i + 1) = Replace(trg.Range("C" & i + 1), "Unit", "")
             Next i
            
            '************************************************************************
            hdr = Array("Sr", "Descriptione", "Production", "Qty")
            
            srow = lrow + 1
            shtname = .Cells(srow, "A")                            ' Third Sheet
            srow = srow + 1
            rcount = WorksheetFunction.CountIf(srcRng, shtname) - 1
            lrow = srow + rcount - 1
            
            Set trg = ThisWorkbook.Worksheets(shtname)
            
             trg.Range("A1").Resize(1, 4) = hdr
            .Range("E" & srow & ":E" & lrow).Copy Destination:=trg.Range("A2")
            .Range("D" & srow & ":D" & lrow).Copy Destination:=trg.Range("B2")
            .Range("B" & srow & ":B" & lrow).Copy Destination:=trg.Range("C2")
            .Range("C" & srow & ":C" & lrow).Copy Destination:=trg.Range("D2")
            
            Set BrandRng = trg.Range("B2:B" & rcount + 1)
            Set OriginRng = trg.Range("C2:C" & rcount + 1)
            Call Get_Origin
        
        End With
        
        Application.ScreenUpdating = True
    
        End Sub
    Sub Get_Origin()
    Dim a, n As Integer, i As Integer, c As Range, Origin As String
    
    a = Range("Short")
    n = 0
    
    For Each c In OriginRng
    
        n = n + 1
        For i = 1 To 7
         BrandRng(n) = Replace(BrandRng(n, 1), a(i, 1), "")
        Next i
        Origin = Application.WorksheetFunction.VLookup(c, Range("liss"), 2, False)
        BrandRng(n, 1).Value = Trim(BrandRng(n, 1).Value) & " " & Origin
        
    Next c
    
    End Sub
    I added POLAND/POL to "LISS" table
    Attached Files Attached Files
    If that takes care of your original question, please select Thread Tools from the menu link above and mark this thread as SOLVED.

Thread Information

Users Browsing this Thread

There are currently 1 users browsing this thread. (0 members and 1 guests)

Similar Threads

  1. Replies: 3
    Last Post: 03-04-2022, 08:30 AM
  2. Replies: 6
    Last Post: 04-22-2021, 03:41 PM
  3. Replies: 7
    Last Post: 11-28-2020, 06:55 PM
  4. Delete and add rows to multiple tables on multiple sheets using inputbox
    By Oliver_watkins in forum Excel Programming / VBA / Macros
    Replies: 4
    Last Post: 02-03-2020, 04:56 AM
  5. Copy Paste multiple tables from multiple sheets into Outlook email
    By DoodlesMama in forum Excel Programming / VBA / Macros
    Replies: 1
    Last Post: 03-25-2015, 12:21 PM
  6. Pivot Tables - need to do separate pivot tables for multiple sheets in same format
    By tconnell1965 in forum Excel Programming / VBA / Macros
    Replies: 0
    Last Post: 09-18-2013, 07:04 AM
  7. [SOLVED] Split a long table to multiple tables
    By amasson in forum Excel Formulas & Functions
    Replies: 5
    Last Post: 05-02-2013, 05:37 AM

Bookmarks

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts

Search Engine Friendly URLs by vBSEO 3.6.0 RC 1