none
Need help in making a data copy macro. RRS feed

  • Question

  • I've got a macro workbook which looks like this:

    When I give a input path(which is the path of a input.xlsx file) and a output path(which is the path of a output.xlsx file) and hit the Generate button, then the macro should open the input file, copy some data and then open the output file and paste it specific locations with inserting new rows so that the data below it does not get overwritten.

    Below is the details of which columns value from input file will be paste in output file

    1. sl. no. --> sl. no.
    2. products --> description of goods
    3. no. of sb --> no. of cartons
    4. (quantity÷no. of sb) --> qty/cartons
    5. total qty. --> quantity
    6. batch no. --> batch no.
    7. mfg. date --> mfg. date
    8. use before --> exp. date
    9. carton no. & dimension of each carton in cm are a bit tricky(better to see attached file to understand)
    10. Wt. of each  SB (Kgs) --> GROSS WT. OF EACH CARTON IN KG (cell V)
    11. shipper box content's [inner bracket multiplication/1000 e.g. (72*80)÷1000] --> NET WT. OF EACH CARTON IN KG (cell Y)

    Now, items 1 to 8 and 10,11 are pretty straight forward copy and paste with some division and multiplication required in some cases.

    I'm really struggling to execute the 9 th operation in the above list. Also, the code I've done is not doing the pasting at all.

    Can anyone help me on this one? I know the question is a bit mouthful but I'm really struggling to this.

    input file:input data

    output file(default):output file(default)

    and expected output file:


    The file containing the macro:

    the code I've done thus far to just check if my process is working(which is not working):

    Private Sub browse1_Click()
     
        Dim fd As FileDialog
        Dim oFD As Variant
        Dim FileName As String
        
        Set fd = Application.FileDialog(msoFileDialogFilePicker)
        With fd
            .ButtonName = "Select"
            .AllowMultiSelect = False
            .Filters.Add "Excel Files", "*.xls?", 1
            .Title = "Choose Excel File"
            .InitialView = msoFileDialogViewDetails
            .Show
            
            For Each oFD In .SelectedItems
                FileName = oFD
            Next oFD
            On Error GoTo 0
        End With
        
        TextBox1.Text = FileName
        
        Set fd = Nothing
     
    End Sub
    
    Private Sub browse2_Click()
    
        Dim fd As FileDialog
        Dim oFD As Variant
        Dim FileName As String
        
        Set fd = Application.FileDialog(msoFileDialogFilePicker)
        With fd
            .ButtonName = "Select"
            .AllowMultiSelect = False
            .Filters.Add "Excel Files", "*.xls?", 1
            .Title = "Choose Excel File"
            .InitialView = msoFileDialogViewDetails
            .Show
            
            For Each oFD In .SelectedItems
                FileName = oFD
            Next oFD
            On Error GoTo 0
        End With
        
        TextBox2.Text = FileName
        
        Set fd = Nothing
    
    End Sub
    
    Private Sub generate_Click()
    
    Dim FSO
    Dim sFile, sFile2 As String
    
    sFile = TextBox1.Text
    sFile2 = TextBox2.Text
    
    Set FSO = CreateObject("Scripting.FileSystemObject")
    
    If Not FSO.FileExists(sFile) Then
        MsgBox "Specified Input File Not Found", vbInformation, "Not Found"
    Else
        If Not FSO.FileExists(sFile2) Then
            MsgBox "Specified Output File Not Found", vbInformation, "Not Found"
        Else
            
        On Error GoTo ErrHandler
        Application.ScreenUpdating = False
        
        Dim src, res As Workbook
        
        Set src = Workbooks.Open(TextBox1.Text)
        Application.AskToUpdateLinks = False
        Application.DisplayAlerts = False
        unMerge
        
        Cells.Find(What:="quantity", After:=ActiveCell, LookIn:=xlFormulas, _
            LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
            MatchCase:=False, SearchFormat:=False).Activate
        ActiveCell.Offset(1, 0).Select
        Range(Selection, Selection.End(xlDown)).Select
        Selection.Copy
        
        Set res = Workbooks.Open(TextBox2.Text)
        Application.AskToUpdateLinks = False
        Application.DisplayAlerts = False
        res.Worksheets("PACK").Activate
        Range("H17").Select
        Selection.Insert Shift:=xlDown
        Application.CutCopyMode = False
        
        
        res.Close
    
        src.Close False
    
    ErrHandler:
            Application.EnableEvents = True
            Application.ScreenUpdating = True
            
            'MsgBox "Specified File Exists", vbInformation, "Exists"
        End If
    End If
    
    
    
    End Sub
    
    Function unMerge()
      For Each cll In ActiveSheet.UsedRange.Cells
      If cll.MergeCells Then
        myValue = Empty
        myFormat = Empty
        Set mergedrange = cll.MergeArea
        mergedrange.unMerge
        For Each celle In mergedrange.Cells
          If IsEmpty(celle.Value) Then
            celle.Value = myValue
            celle.NumberFormat = myFormat
          Else
            myValue = celle.Value
            myFormat = celle.NumberFormat
          End If
        Next celle
      End If
      Next cll
    End Function

    I'm not getting any error in the code either.

    Thanks.



    • Edited by Don Bradman Friday, November 22, 2019 4:21 PM
    Friday, November 22, 2019 3:51 PM

All replies

  • Hi Don Bradman,

    It would be a time-consuming task for me to reproduce your Excel book.
    Could you share your file via cloud storage such as OneDrive, Dropbox, etc?

    # Remember to edit/modify your vital/private data before sharing.

    Regards,

    Ashidacchi -- http://hokusosha.com


    • Edited by Ashidacchi Saturday, November 23, 2019 2:33 AM
    Saturday, November 23, 2019 2:25 AM
  • Hi Ashidacchi,

    I've already share two files input/database and default_output in my post above.

    Anyways, here you go...

    database file

    default_output_structure

    expected_outout

    userform

    Regards,

    Don


    • Edited by Don Bradman Saturday, November 23, 2019 5:14 AM
    Saturday, November 23, 2019 4:45 AM
  • Hi Don,

    Thank you for sharing your files.

    I'm afraid your Input file (data.xlsx) is somewhat insufficient or not perfect as an input data.
    Merged cells and UnMerged cells are mixed in one column. Examine [Sl. No.], [Products] , and [Batch No.], etc.
    If such mixture exist, it is hard or complicated to calculate (quantity / No of sb) or (total qty). (Calculation is not impossible, but gets harder.)

    I recommend to make input data consolidated in your working environments/system, if you write VBA code for automation.

    Regards,


    Ashidacchi -- http://hokusosha.com



    • Edited by Ashidacchi Sunday, November 24, 2019 3:10 AM
    Sunday, November 24, 2019 3:04 AM
  • Hi Ashidacchi,

    I know its hard to copy data from a mixture of merged and unmerged cells, that is why I used a unMerge function to unmerge the merged cells to my liking in the beginning of my code so that it does not cause any issue.

    Regards,

    Don

    Sunday, November 24, 2019 3:33 AM
  • Hi Don,

    I've made a sample for copying input.xlsx to output.xlsx.
    (This will copy only column [A] and [B].)

    [this is in userform.xlsm]
    Option Explicit
    
    ' === variables ====================
    ' ------ Workbook
    Private WB_Input As Workbook
    Private WB_Output As Workbook
    ' ------ Rows count to be inserted in Output
    Private InsertCnt As Integer
    
    ' === Input [Browse] button ====================
    Private Sub btn_Browse_Input_Click()
        Dim fd As FileDialog
        ' ---
        Set fd = Application.FileDialog(msoFileDialogFilePicker)
        With fd
            .ButtonName = "Select"
            .AllowMultiSelect = False
            .Filters.Add "Excel Files", "*.xls?", 1
            .Title = "Choose Input File"
            .InitialView = msoFileDialogViewDetails
        End With
        ' ---
        If (fd.Show = True) Then
            TextBox1.Text = fd.SelectedItems(1)
        Else
            MsgBox "Select Input File"
            TextBox1.Text = ""
        End If
        ' ---
        Set fd = Nothing
    End Sub
    
    ' === Output [Browse] button ====================
    Private Sub btn_Browse_Output_Click()
        Dim fd As FileDialog
        ' ---
        Set fd = Application.FileDialog(msoFileDialogFilePicker)
        With fd
            .ButtonName = "Select"
            .AllowMultiSelect = False
            .Filters.Add "Excel Files", "*.xls?", 1
            .Title = "Choose Output File"
            .InitialView = msoFileDialogViewDetails
        End With
        ' ---
        If (fd.Show = True) Then
            TextBox2.Text = fd.SelectedItems(1)
        Else
            MsgBox "Select Output File"
            TextBox1.Text = ""
        End If
        ' ---
        Set fd = Nothing
    End Sub
    
    ' === [Generate] button ===========================
    Private Sub btn_Generate_Click()
        ' --(1) Check if files are selected and files exist
        If (fnc_Check_Files = False) Then
            Exit Sub
        End If
        ' --(2) Open Input file & UnMerge
        Call prc_Open_Input
        ' --(3) Open Output file & Insert rows
        Call prc_Open_Output_InsertRows
        ' --(4) Copy data (Input:from row 6 >> Output:from row 17)
        Call prc_Copy_Data
        ' --- Close Input & Output, if needed
        ' -- WB_Output.Close
        ' -- WB_Output.Close
    End Sub
    
    ' ===[Function] check if files are selected, exist =============
    Private Function fnc_Check_Files() As Boolean
        fnc_Check_Files = True
        ' ---
        If (TextBox1.Text = "" Or TextBox2.Text = "") Then
            MsgBox "Select Input/Output file"
            fnc_Check_Files = False
            Exit Function
        End If
        ' --- check if files exist
        If Dir(TextBox1.Text) = "" Then
            MsgBox "input file does not exist", vbExclamation
            fnc_Check_Files = False
            Exit Function
        End If
        If Dir(TextBox2.Text) = "" Then
            MsgBox "output file does not exist", vbExclamation
            fnc_Check_Files = False
            Exit Function
        End If
    End Function
    
    ' === Open Input File ====================
    Private Sub prc_Open_Input()
        ' --- Open input file
        Set WB_Input = Workbooks.Open(TextBox1.Text)
        ' --- Get lastRow and decide InsertCnt
        Dim lastRow As Integer
        lastRow = WB_Input.Sheets("DTL").Cells(Rows.Count, 6).End(xlUp).Row
        InsertCnt = lastRow - 6 ' --6:header rows
        ' --- for debugging
        'MsgBox "lastRoww = " & lastRow & vbCrLf & "InsertCnt = " & InsertCnt ' --<< for debugging
    End Sub
    
    ' === Open Output file & Insert rows ====================
    Private Sub prc_Open_Output_InsertRows()
        ' --- Open Output File
        Set WB_Output = Workbooks.Open(TextBox2.Text)
        ' --- Edit Output
        With WB_Output.Sheets("PACK")
            ' --- Insert rows for Packing Description
            .Range("A17:E" & 17 + InsertCnt).EntireRow.Insert
        End With
    End Sub
    
    ' ===
    Private Sub prc_Copy_Data()
        Application.ScreenUpdating = False
        Application.DisplayAlerts = False
        
        With WB_Output.Sheets("PACK")
            ' --- Copy Input > Output
            .Range("A17:B" & 17 + InsertCnt - 1).Value _
                = WB_Input.Sheets("DTL").Range("A7:B" & 7 + InsertCnt - 1).Value
        End With
        ' ---
        Application.DisplayAlerts = True
        Application.ScreenUpdating = True
    End Sub
    

    Regards,

    Ashidacchi -- http://hokusosha.com

    Monday, November 25, 2019 2:41 AM
  • Hi Don,

    Sorry, I provided incomplete code in the previous post.
    This is revised version.
    Private Sub prc_Copy_Data()
        Application.ScreenUpdating = False
        Application.DisplayAlerts = False
        
        With WB_Output.Sheets("PACK")
            ' --- Copy Input > Output
            .Range("A17:B" & 17 + InsertCnt - 1).Value _
                = WB_Input.Sheets("DTL").Range("A7:B" & 7 + InsertCnt - 1).Value
            ' --- Merge [B]-[E]
            Dim myRow As Integer
            For myRow = 17 To 17 + InsertCnt
                .Range("B" & myRow & ":E" & myRow).Merge
            Next
            ' --- display format
            .Range("A17:E" & 17 + InsertCnt).HorizontalAlignment = xlLeft
            .Range("A17:E" & 17 + InsertCnt).EntireRow.RowHeight = 16
            .Range("A17:AC" & 17 + InsertCnt).Interior.ColorIndex = 2
        End With
        
        ' ---
        Application.DisplayAlerts = True
        Application.ScreenUpdating = True
    End Sub
    Regards,

    Ashidacchi -- http://hokusosha.com

    Monday, November 25, 2019 5:57 AM
  • Hi Ashidacchi,

    Thanks for your time and effort but your code is messing with the format, structure and producing result like:

    I know my input data is not ideally structured but...

    Anyways, can you show me how can I create the result for the column CARTON NO.

    I'm really finding it difficult to produce that...

    Regards,

    -----------

    Don

    Monday, November 25, 2019 12:59 PM
  • Hi Don,

    I have been making code which would (I hope) satisfy all your needs for three days.  I sometimes think it must be a paid work (I don't want money, but it requires much effort/time).

    I hope you will ask one issue per one thread.

    Regards,

    Ashidacchi -- http://hokusosha.com

    P.S.
      How should we get CARTON NO?  Explain its algorithm.
      (I don't know your business at all.)
    • Edited by Ashidacchi Monday, November 25, 2019 1:25 PM
    Monday, November 25, 2019 1:18 PM
  • Hi Ashidacchi,

    The CARTON NO. column basically writes the ranges starting from 1 to the count of no. of SB in the data.xlsx input file i.e., since the value for no. of SB in cell H7(data.xlsx) is 5 and since it is the starting of that column its equivalent CARTON NO. will be 1/113 To 5/113, where 113 is the Total of no. of SB. So, for cell H8's equivalent CARTON NO. value will be 6/113 To 6/113 as H8's value is 1 and the previous value ended with 5/113. Here is a formula that almost does the job but not totally:

    =SUM([data.xlsx]DTL!$H$7:[data.xlsx]DTL!H7)+1&"/"&SUM([data.xlsx]DTL!$H$7:[data.xlsx]DTL!$H$27)&" To "&SUM([data.xlsx]DTL!$H$7:[data.xlsx]DTL!H8)&"/"&SUM([data.xlsx]DTL!$H$7:[data.xlsx]DTL!$H$27)

    I have to put this using VBA in cell L18 and use the drag down fill to fill the below cells, but it cannot give the result in cell L17 whose value should be 1/113 To 5/113.

    Hope I made it a little more understandable than before.


    Regards,

    -----------

    Don



    • Edited by Don Bradman Monday, November 25, 2019 3:21 PM
    Monday, November 25, 2019 2:12 PM