vba help to shorten the my code...

[malleshg24]

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

[Hightree]

Please show us the code

[jolivanes]

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

[malleshg24]

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

[jolivanes]

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

[jolivanes]

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.

[malleshg24]

Hi Jolivnanes,

Thank you some much, it worked :clap:!!


Regards,
Mallesh

[jolivanes]

Thanks for updating us
Good luck