Consulting

Results 1 to 8 of 8

Thread: vba help to shorten the my code...

  1. #1
    Banned VBAX Contributor
    Joined
    Aug 2017
    Posts
    144
    Location

    vba help to shorten the my code...

    Hi Team,
    
    
    I want to Copy Paste Data from Dataworkbook to Masterworkbook.
    copying of 4 Datasheet one by one and pasting in Masterworkbooks sheets one by one excluding header.
    
    My code works but is it possible to shorten the code?... 
    
    Thanks in advance for your precious time. 
    
    
    
    
    
    
    Regards,
    Mallesh
    Attached Files Attached Files

  2. #2
    VBAX Regular
    Joined
    Jan 2018
    Location
    The Netherlands
    Posts
    45
    Location
    Please show us the code

  3. #3
    As Mr Hogenboom alluded to, don't be shy to show your code.
    Maybe
    lr =Osh.Cells(Rows.Count, 1).End(xlUp).Row
    If lr > 1 Then
    MOsh.Cells(Rows.Count, 3).End(xlUp).Offset(1).Resize(lr - 1).Value = Osh.Range("A2").Resize(lr - 1).Value
    MIsh.Cells(Rows.Count, 3).End(xlUp).Offset(1).Resize(lr - 1).Value = Ish.Range("A2").Resize(lr - 1).Value
    MRsh.Cells(Rows.Count, 3).End(xlUp).Offset(1).Resize(lr - 1).Value = Rsh.Range("A2").Resize(lr - 1).Value
    MEsh.Cells(Rows.Count, 3).End(xlUp).Offset(1).Resize(lr - 1).Value = Esh.Range("A2").Resize(lr - 1).Value
    End If

  4. #4
    Banned VBAX Contributor
    Joined
    Aug 2017
    Posts
    144
    Location
    Hi jolivanes,
    
    Thanks for quick reply, 
    I forgot to mention , First of all I need to activate the sheet
    take the LR , if it is greater than 1 then copy that data and paste in Masterworkbooks specified sheet
    
    Then activate Sheet2 chek LR if >1 then  Copy and Paste in Masterworkbooks Sheet2
    I am running this macro on all files on a folder, 
    
    Option Explicit
    Dim lr As Long
    
    
    Sub test()
    
    
    Dim Datawbk As Workbook
    Dim Mwbk As Workbook
    
    
    Set Datawbk = Workbooks.Open(ThisWorkbook.Worksheets("Macro").Range("b5").Value, ReadOnly:=True)
    Set Mwbk = Workbooks.Open(ThisWorkbook.Worksheets("Macro").Range("b8").Value, ReadOnly:=True)
    
    
    'Worksheets of Dataworkbook
    Dim Osh As Worksheet, Ish As Worksheet, Rsh As Worksheet, Esh As Worksheet
    
    
    Set Osh = Datawbk.Worksheets("OutgoingCall")
    Set Ish = Datawbk.Worksheets("IncomingCall")
    Set Rsh = Datawbk.Worksheets("Reviewer")
    Set Esh = Datawbk.Worksheets("Executed")
    
    
    
    
    'Worksheets of MasterWorkbook
    Dim MOsh As Worksheet, MIsh As Worksheet, MRsh As Worksheet, Mesh As Worksheet
    
    
    Set MOsh = Mwbk.Worksheets("Out")
    Set MIsh = Mwbk.Worksheets("Inc")
    Set MRsh = Mwbk.Worksheets("Review1")
    Set Mesh = Mwbk.Worksheets("Exec")
    
    
    'Now Copying each Dataworkbooks Data into Masterwork
    
    
    Datawbk.Activate
    
    
    
    
    'Need your help here, how to shortn below code
    
    
    '-----------------------------------
    Osh.Activate
    lr = Osh.Range("a1000").End(xlUp).Row
    
    
    If lr > 1 Then
        Osh.Range("a1").CurrentRegion.Resize(lr - 1).Offset(1).Copy
        MOsh.Range("a50000").End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
    End If
    
    
    '---------------------------
    Ish.Activate
    lr = 0
    lr = Ish.Range("a1000").End(xlUp).Row
    If lr > 1 Then
        Ish.Range("a1").CurrentRegion.Resize(lr - 1).Offset(1).Copy
        MIsh.Range("a50000").End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
    End If
    
    
    '----------------------------
    Rsh.Activate
    lr = 0
    lr = Rsh.Range("a1000").End(xlUp).Row
    
    
    If lr > 1 Then
        Rsh.Range("a1").CurrentRegion.Resize(lr - 1).Offset(1).Copy
        MRsh.Range("a50000").End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
    End If
    
    
    '--------------------
    Esh.Activate
    lr = 0
    lr = Esh.Range("a1000").End(xlUp).Row
    
    
    If lr > 1 Then
        Esh.Range("a1").CurrentRegion.Resize(lr - 1).Offset(1).Copy
        Mesh.Range("a50000").End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
    End If
    
    
    Datawbk.Close savechanges:=False
    
    
    End Sub

  5. #5
    Should that be "Mesh" or "MEsh"?
    Also, are the last used rows 5000 and in one sheet 1000 exactly?

  6. #6
    Maybe
    Dim shtArr1, shtArr2, i As Long, lr As Long
    shtArr1 = Array("Osh", "Ish", "Rsh", "Esh")
    shtArr2 = Array("MOsh", "MIsh", "MRsh", "MEsh")
        For i = LBound(shtArr1) To UBound(shtArr1)
            With Sheets(shtArr1(i))
                lr = .Cells(.Rows.Count, 1).End(xlUp).Row
                If lr > 1 Then Sheets(shtArr1(i)).Range("A1").CurrentRegion.Resize(lr - 1).Offset(1).Copy Sheets(shtArr2(i)).Cells(Rows.Count, 1).End(xlUp).Offset(1)
            End With
        Next i
    Datawbk.Close savechanges:=False
    no need to activate or select sheets.

  7. #7
    Banned VBAX Contributor
    Joined
    Aug 2017
    Posts
    144
    Location
    Hi Jolivnanes,

    Thank you some much, it worked !!


    Regards,
    Mallesh

  8. #8
    Thanks for updating us
    Good luck

Posting Permissions

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