4 Replies - 174 Views - Last Post: 10 December 2018 - 01:42 AM Rate Topic: -----

#1 Ani.   User is offline

  • New D.I.C Head

Reputation: 0
  • View blog
  • Posts: 7
  • Joined: 03-December 18

join 2 codes

Posted 10 December 2018 - 12:06 AM

Hi, I need to join 2 codes to copy info from 1 workbook to another,Can anybody help me?
First code
Public Const BOOK = "CopySheets.xlam"
Sub CopySheets()
'
' CopySheets Macro
' Macro recorded 17/08/2005 by Stepan Ghazaryan
'
' Keyboard Shortcut: Ctrl+t
'
UserForm1.Show
End Sub
Sub Copying()
On Error GoTo ErrorHandler
Dim Count As Integer
Count = 0
If UserForm1.tSheetName.Value <> "" Then
Set NewWorkbook = Workbooks.Add
NewWorkbook.SaveAs Filename:="D:\Result.xls"
OpenFiles = Dir(UserForm1.tPath.Value & "\" & Trim(UserForm1.cFileName.Value))
While OpenFiles <> ""
     Workbooks.Open Filename:=UserForm1.tPath.Value & "\" & OpenFiles
     Workbooks(OpenFiles).Sheets(UserForm1.tSheetName.Value).Copy before:=Workbooks("Result.xls").Sheets(1)
     Workbooks("Result.xls").Sheets(UserForm1.tSheetName.Value).Name = UserForm1.tSheetName.Value & "_" & Trim(Left(OpenFiles, Len(OpenFiles) - 4))
     Workbooks(OpenFiles).Close SaveChanges:=False
     OpenFiles = Dir()
Wend
Else
    MsgBox "Please Insert the Excel sheet name !!!!"
End If
Workbooks("Result.xls").Activate
    If Count > 0 Then
        MsgBox "In " & Count / 2 & " workbooks not have worksheet name where you specified !!!"
    End If
Exit Sub
ErrorHandler:
    If Err.Number = 9 Then
        Count = Count + 1
        Resume Next
    
    Else
    MsgBox "Error in macros code !!!! " & Err.Description & " " & Err.HelpContext
    End If

End Sub

Sub ByBankCopying(BankCode As String)
On Error GoTo ErrorHandler
Dim Count As Integer
Count = 0

Set NewWorkbook = Workbooks.Add
NewWorkbook.Application.DisplayAlerts = False

NewWorkbook.SaveAs Filename:="D:\Result.xls", ConflictResolution:=Excel.XlSaveConflictResolution.xlLocalSessionchanges
 
OpenFiles = Dir(UserForm1.tPath.Value & "\" & Trim(UserForm1.cFileName.Value))
NewWorkbook.Application.DisplayAlerts = True

While OpenFiles <> ""
     tmpSheetname = "*_" & UserForm1.tSheetName.Value & "_*"
     Workbooks.Open Filename:=UserForm1.tPath.Value & "\" & OpenFiles
     icount = 0
     While icount < Workbooks(OpenFiles).Sheets.Count
        If Workbooks(OpenFiles).Sheets(icount + 1).Name Like tmpSheetname Then
            Workbooks(OpenFiles).Sheets(icount + 1).Copy before:=Workbooks("Result.xls").Sheets(1)
        End If
     icount = icount + 1
     Wend
  

     Workbooks(OpenFiles).Close SaveChanges:=False
     OpenFiles = Dir()
Wend

    If Count > 0 Then
        MsgBox "In " & Count / 2 & " workbooks not have worksheet name where you specified !!!"
    End If
    Workbooks("Result.xls").SaveAs Filename:=UserForm1.tPath.Value & "\Result\" & BankCode & ".xls"
    Workbooks(BankCode & ".xls").Close SaveChanges:=True
Exit Sub
ErrorHandler:
    If Err.Number = 9 Then
        Count = Count + 1
        Resume Next

    Else
    MsgBox "Error in macros code !!!! " & Err.Description & " " & Err.HelpContext
    End If

End Sub



Second Code
Sub Copy_Paste()
'
' Keyboard Shortcut: Ctrl+s
  FR = Sheet4.Cells(Rows.Count, 1).End(xlDown).Row

  Sheet4.Range("A2:N" & FR).ClearContents
  Sheet4.Range("A2:N" & FR).ClearFormats


acColNum = 2
acRowsNum = 10

acCpRowG = 2
acCpRow = 0

acPeriod = 1
While acPeriod < 5
While Sheets(acPeriod).Cells(2, acColNum).Value <> ""
    While Sheets(acPeriod).Cells(acRowsNum, 1).Value <> ""
       Sheets(acPeriod).Select
       ActiveSheet.Range(Cells(2, acColNum), Cells(8, acColNum)).Copy
       Sheets(4).Select
       ActiveSheet.Range("A" & acCpRowG + acCpRow).PasteSpecial Transpose:=True
       Sheets(acPeriod).Select
       ActiveSheet.Cells(acRowsNum, 1).Copy
       Sheets(4).Select
       ActiveSheet.Cells(acCpRowG + acCpRow, 8).Value = acPeriod + 3
       ActiveSheet.Cells(acCpRowG + acCpRow, 10).Select
       ActiveSheet.Paste
       Sheets(acPeriod).Select
       ActiveSheet.Cells(acRowsNum, acColNum).Copy
       Sheets(4).Select
       
       ActiveSheet.Cells(acCpRowG + acCpRow, 11).Select
       ActiveSheet.Paste
       acCpRow = acCpRow + 1
       acRowsNum = acRowsNum + 1
    Wend
    acCpRowG = acCpRowG + acCpRow
    acColNum = acColNum + 1
    acRowsNum = 10
    acCpRow = 0
Wend
acColNum = 2
acRowsNum = 10
acCpRow = 0
acPeriod = acPeriod + 1
Wend
End Sub



I must use it as Add In,

Is This A Good Question/Topic? 0
  • +

Replies To: join 2 codes

#2 andrewsw   User is offline

  • awks lol ffs
  • member icon

Reputation: 6693
  • View blog
  • Posts: 27,474
  • Joined: 12-December 12

Re: join 2 codes

Posted 10 December 2018 - 01:24 AM

Join together in what way, what should the combined code achieve?
What have you attempted and what is confusing you?

If you just want to call a second procedure when one procedure completes then you would just use Call ProcName() but I assume there is more to your request.
Was This Post Helpful? 0
  • +
  • -

#3 Ani.   User is offline

  • New D.I.C Head

Reputation: 0
  • View blog
  • Posts: 7
  • Joined: 03-December 18

Re: join 2 codes

Posted 10 December 2018 - 01:29 AM

Here is the code of join, but it isn't work correctly. I can't find mistakes
Public Const BOOK = "CopySheets.xlam"
Sub CopySheets()
'
' CopySheets Macro
' Macro recorded 17/08/2005 by Stepan Ghazaryan
'
' Keyboard Shortcut: Ctrl+t
'
UserForm1.Show
End Sub
Sub Copying()
On Error GoTo ErrorHandler
Dim Count As Integer
Count = 0
If UserForm1.tSheetName.Value <> "" Then
Set NewWorkbook = Workbooks.Add
NewWorkbook.SaveAs Filename:="D:\Result.xlsx"
OpenFiles = Dir(UserForm1.tPath.Value & "\" & Trim(UserForm1.cFileName.Value))
While OpenFiles <> ""
     Workbooks.Open Filename:=UserForm1.tPath.Value & "\" & OpenFiles
      FR = Sheet4.Cells(Rows.Count, 1).End(xlDown).Row

  Sheet4.Range("A2:N" & FR).ClearContents
  Sheet4.Range("A2:N" & FR).ClearFormats


acColNum = 2
acRowsNum = 10

acCpRowG = 2
acCpRow = 0

acPeriod = 1
While acPeriod < 4
While Sheets(acPeriod).Cells(2, acColNum).Value <> ""
    While Sheets(acPeriod).Cells(acRowsNum, 1).Value <> ""
       Sheets(acPeriod).Select
       ActiveSheet.Range(Cells(2, acColNum), Cells(8, acColNum)).Copy
       Sheets(4).Select
       ActiveSheet.Range("A" & acCpRowG + acCpRow).PasteSpecial Transpose:=True
       Sheets(acPeriod).Select
       ActiveSheet.Cells(acRowsNum, 1).Copy
       Sheets(4).Select
       ActiveSheet.Cells(acCpRowG + acCpRow, 8).Value = acPeriod + 3
       ActiveSheet.Cells(acCpRowG + acCpRow, 10).Select
       ActiveSheet.Paste
       Sheets(acPeriod).Select
       ActiveSheet.Cells(acRowsNum, acColNum).Copy
       Sheets(4).Select
       ActiveSheet.Cells(acCpRowG + acCpRow, 11).Select
       ActiveSheet.Paste
       acCpRow = acCpRow + 1
       acRowsNum = acRowsNum + 1
    Wend
    acCpRowG = acCpRowG + acCpRow
    acColNum = acColNum + 1
    acRowsNum = 10
    acCpRow = 0
Wend
acColNum = 2
acRowsNum = 10
acCpRow = 0
acPeriod = acPeriod + 1
Wend
     Workbooks(OpenFiles).Sheets(UserForm1.tSheetName.Value).Copy before:=Workbooks("Result.xlsx").Sheets(1)
     Workbooks("Result.xlsx").Sheets(UserForm1.tSheetName.Value).Name = UserForm1.tSheetName.Value & "_" & Trim(Left(OpenFiles, Len(OpenFiles) - 4))
     Workbooks(OpenFiles).Close SaveChanges:=False
     OpenFiles = Dir()
Wend
Else
    MsgBox "Please Insert the Excel sheet name !!!!"
End If
Workbooks("Result.xlsx").Activate
    If Count > 0 Then
        MsgBox "In " & Count / 2 & " workbooks not have worksheet name where you specified !!!"
    End If
Exit Sub
ErrorHandler:
    If Err.Number = 9 Then
        Count = Count + 1
        Resume Next
    
    Else
    MsgBox "Error in macros code !!!! " & Err.Description & " " & Err.HelpContext
    End If

End Sub

Sub ByBankCopying(BankCode As String)
On Error GoTo ErrorHandler
Dim Count As Integer
Count = 0

Set NewWorkbook = Workbooks.Add
NewWorkbook.Application.DisplayAlerts = False

NewWorkbook.SaveAs Filename:="D:\Result.xlsx", ConflictResolution:=Excel.XlSaveConflictResolution.xlLocalSessionchanges
 
OpenFiles = Dir(UserForm1.tPath.Value & "\" & Trim(UserForm1.cFileName.Value))
NewWorkbook.Application.DisplayAlerts = True

While OpenFiles <> ""
     tmpSheetname = "*_" & UserForm1.tSheetName.Value & "_*"
     Workbooks.Open Filename:=UserForm1.tPath.Value & "\" & OpenFiles
     icount = 0
     While icount < Workbooks(OpenFiles).Sheets.Count
        If Workbooks(OpenFiles).Sheets(icount + 1).Name Like tmpSheetname Then
            Workbooks(OpenFiles).Sheets(icount + 1).Copy before:=Workbooks("Result.xlsx").Sheets(1)
        End If
     icount = icount + 1
     Wend
  

     Workbooks(OpenFiles).Close SaveChanges:=False
     OpenFiles = Dir()
Wend

    If Count > 0 Then
        MsgBox "In " & Count / 2 & " workbooks not have worksheet name where you specified !!!"
    End If
    Workbooks("Result.xls").SaveAs Filename:=UserForm1.tPath.Value & "\Result\" & BankCode & ".xlsx"
    Workbooks(BankCode & ".xlsx").Close SaveChanges:=True
Exit Sub
ErrorHandler:
    If Err.Number = 9 Then
        Count = Count + 1
        Resume Next

    Else
    MsgBox "Error in macros code !!!! " & Err.Description & " " & Err.HelpContext
    End If

End Sub


Was This Post Helpful? 0
  • +
  • -

#4 andrewsw   User is offline

  • awks lol ffs
  • member icon

Reputation: 6693
  • View blog
  • Posts: 27,474
  • Joined: 12-December 12

Re: join 2 codes

Posted 10 December 2018 - 01:38 AM

In what way does it not work? What is supposed to happen and what does happen? Are there error messages?

To be able to successfully connect two pieces of code you should first be able to describe what the result will be (and, of course, have some understanding of the code itself).
Was This Post Helpful? 0
  • +
  • -

#5 Ani.   User is offline

  • New D.I.C Head

Reputation: 0
  • View blog
  • Posts: 7
  • Joined: 03-December 18

Re: join 2 codes

Posted 10 December 2018 - 01:42 AM

It must copy the sheet of 1 workbook and past it in another workbook, but in pasttransponse mode: It gives Run time error: I undersant 2 codes structure and meaning, but can't join them correctly
Was This Post Helpful? 0
  • +
  • -

Page 1 of 1