Loop through master sales sheet and copy data to different workbook and worksheets

[Andy15]

Hi Guys,

I have a sales workbook that has a new worksheet added every week with latest product sales. I also have a total sales workbook that has a different named tab for every product name.

At the moment I have a macro that is run on the Master sales workbook and with the aid of a pop up box asks for the product name. The macro then opens my total sales workbook, checks if there is a sheet already existing with the product name, if not it creates the sheet, then the relevant sales data is pasted after any existing data.

The data is in columns but the product names start on column 3 row 2 and continue along the columns. Each weekly sheet can have different number of columns of data.

[TABLE="width: 500"]
<tbody>[TR]
[TD]date[/TD]
[TD]price[/TD]
[TD]shop[/TD]
[TD]shop[/TD]
[TD]shop[/TD]
[TD]shop[/TD]
[/TR]
[TR]
[TD]???[/TD]
[TD]???[/TD]
[TD]tuna[/TD]
[TD]ham[/TD]
[TD]beans[/TD]
[TD]peas[/TD]
[/TR]
[TR]
[TD]???[/TD]
[TD]???[/TD]
[TD]???[/TD]
[TD]???[/TD]
[TD]???[/TD]
[TD]???[/TD]
[/TR]
[TR]
[TD]???[/TD]
[TD]???[/TD]
[TD]???[/TD]
[TD]???[/TD]
[TD]???[/TD]
[TD]???[/TD]
[/TR]
[TR]
[TD]???[/TD]
[TD]???[/TD]
[TD]???[/TD]
[TD]???[/TD]
[TD]???[/TD]
[TD]???[/TD]
[/TR]
[TR]
[TD]???[/TD]
[TD]???[/TD]
[TD]???[/TD]
[TD]???[/TD]
[TD]???[/TD]
[TD]???[/TD]
[/TR]
</tbody>[/TABLE]

The columns in red are common to all data so the code copies columns 1,2 and relevant additional column based on product name.

Here is my code so far;

Sub MoveInfo_Active_sales()


Dim wbOpen As String
Dim ShtOpen As String
Dim lastRow As Long
Dim LastCol As Long
Dim ClrMessage As String
Dim ClrRng As Range
Dim wb As Workbook
Dim wks As Worksheet
Dim ws As Worksheet
Dim startCol As String
Dim startRow As Long
Dim myCol As String
Dim last_col As Integer
Dim c As Integer
Dim myValue As Variant
Dim Caption As String
Dim LastColumn As Integer
Dim newSheetName As String
Dim checkSheetName As String




ShtOpen = InputBox("Type the name of the sheet where you want the data to be placed ")
If StrPtr(ShtOpen) = 0 Then Exit Sub


Workbooks.Open ("file:///\\\\Mac\Home\Documents\totalsales.xlsm")




Set wb = Workbooks("2017 sales.xlsm")
    
    newSheetName = ShtOpen
                                    
    On Error Resume Next
    checkSheetName = Worksheets(newSheetName).Name
    If checkSheetName = "" Then
        Worksheets.Add.Name = newSheetName
        
    End If


Set wks = Sheets(ShtOpen)
last_col = wks.Cells(2, Columns.Count).End(xlToLeft).Column + 3


    myValue = ShtOpen
    Caption = myValue
    wb.Activate
    
    Application.ScreenUpdating = False
       
         With ActiveSheet
        LastColumn = .Cells(2, .Columns.Count).End(xlToLeft).Column
    End With
            
            For c = 3 To LastColumn
                If Cells(2, c) Like Caption Then
                
                    Range("A1").EntireColumn.Copy
                    wks.Activate
                    Columns(last_col).End(xlToLeft).Offset(0, 1).Select
                    ActiveSheet.Paste
                    wb.Activate
                    
                    Range("B1").EntireColumn.Copy
                    wks.Activate
                    Columns(last_col).End(xlToLeft).Offset(0, 1).Select
                    ActiveSheet.Paste
                    wb.Activate
                    
                    Columns(c).Copy
                    wks.Activate
                    Columns(last_col).End(xlToLeft).Offset(0, 1).Select
                    ActiveSheet.Paste
                    ActiveWorkbook.Save
                    wb.Activate
                    
                
                Application.CutCopyMode = False
                
                End If
                
                Columns.AutoFit
                
            Next c
            last_col = last_col + 1




Application.ScreenUpdating = True


MsgBox "Data Copied"
    
End Sub
Function GetColumnLetter(colNum As Long) As String
    Dim vArr
    vArr = Split(Cells(1, colNum).Address(True, False), "$")
    GetColumnLetter = vArr(0)
End Function

To summarise I am looking for a way to automate this section;
ShtOpen = InputBox("Type the name of the sheet where you want the data to be placed ")

by way of looping through all the columns on the master worksheet copying the data and pasting it to the total sales workbook relevant sheet.

Thanks for any help
Andy

 

[WarPigl3t]

I'm going to assume your current code works.

'Constant Variables
Public Const headerRow_dataSheet = 1
Public Const firstColumn_dataSheet = 3
Public Const firstRow_dataSheet = 2
Public Const dateColumn_dataSheet = 1
Public Const priceColumn_dataSheet = 2

Sub [COLOR=#333333]MoveInfo_Active_sales()
[/COLOR]     'Variables
     dataSheet = ActiveSheet.Name
     lastRow_dataSheet = Sheets(dataSheet).Cells(Rows.Count, priceColumn_dataSheet).End(xlUp).Row
     lastColumn_dataSheet = Sheets(dataSheet).Cells(headerRow_dataSheet, Columns.Count).End(xlToLeft).Column
     r_dataSheet = firstRow_dataSheet
     Do Until r_dataSheet > lastRow_dataSheet
          c_dataSheet = firstColumn_dataSheet
          Do Until c_dataSheet > lastColumn_dataSheet
               evaluatingValue = Sheets(dataSheet).Cells(r_dataSheet, c_dataSheet).Value
               evaluatingDate = Sheets(dataSheet).Cells(r_dataSheet, dateColumn_dataSheet).Value
               evaluatingPrice = Sheets(dataSheet).Cells(r_dataSheet, priceColumn_dataSheet).Value
               '.........................
               'You now have three evaluating variables.  _
               You seem capable to know what to do with them from here. _
               .........................
               c_dataSheet = c_dataSheet + 1
          Loop
          r_dataSheet = r_dataSheet + 1
     Loop
End Sub

 

[Andy15]

Hi,

Thanks for the above code. your time is much appreciated.