PDA

View Full Version : vba help to shorten the my code...



malleshg24
08-02-2018, 12:20 PM
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
08-03-2018, 03:54 AM
Please show us the code

jolivanes
08-03-2018, 08:29 PM
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
08-16-2018, 01:03 PM
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
08-16-2018, 02:28 PM
Should that be "Mesh" or "MEsh"?
Also, are the last used rows 5000 and in one sheet 1000 exactly?

jolivanes
08-16-2018, 03:13 PM
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
08-16-2018, 06:43 PM
Hi Jolivnanes,

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


Regards,
Mallesh

jolivanes
08-16-2018, 07:59 PM
Thanks for updating us
Good luck