Excel VBA Course
Excel VBA Course - From Beginner to Expert

200+ Video Lessons
50+ Hours of Video
200+ Excel Guides

Become a master of VBA and Macros in Excel and learn how to automate all of your tasks in Excel with this online course. (No VBA experience required.)

View Course

getting data from sheet to multiple sheets before TOTAL row



I  try  getting data from  first sheet  to  the  others  sheets based on column A , if  the  names  in column A are  matched with  sheet name  ,then  should  add  data before TOTAL row  with calculation new added data in TOTAL row  for each sheet . it  should  start from row 18  for  each  sheet  because  the rows where precede it  I have  to  fill manually .

note:  when  bring data  should  not  copy  to  the  bottom repeatedly  as  my code  does it . should  clear from before TOTAL row  and after  row 17  if  there is  existed  from basic  before bring  data from  first  sheet.

I use  in  my  code  select  and  paste . seems  bad  way  !!

Sub getting_values()
Set WS = ActiveWorkbook.Sheets("MAIN")
Dim cl As Range, i As Integer
For i = 1 To Sheets.Count
For Each cl In WS.Range("a13:a" & WS.[a10000].End(xlUp).Row)
If cl.Value = Sheets(i).Name Then

Sheets(i).Range("a" & Sheets(i).[a10000].End(xlUp).Row + 1).EntireRow.Insert

cl.Offset(0, 2).Resize(1, 5).Copy
Sheets(i).Range("a" & Sheets(i).[a10000].End(xlUp).Row + 1).PasteSpecial xlPasteValues
End If

End Sub

any way to guide me how arrange this chaos for this code,please?



Selected Answer


In the revised file attached, new Module 2 has a new sub to clear existing data on sheets (other than MAIN). The code just loops through sheets and deletes any rws betwen 17 and the TOTAL row (I've added some duplicated data in tbefile as it leaves me, so you can see it work within the main macro):

Sub ClearData()

For i = 1 To Sheets.Count
    If Sheets(i).Name <> "MAIN" Then
        With Sheets(i)
            B4Tot = .Range("C" & .Rows.Count).End(xlUp).Row - 1
            ' delete any rows between 17 and row with "Total" in C
            If B4Tot >= 17 Then .Rows("17:" & B4Tot).EntireRow.Delete
        End With
    End If

Next i

End Sub

This gets called in the revised code below which adds new row (with the fomat of existing data rows above) and also writes the formula in cells added in columns E and F of each sheet. It's commented so you can see what's happening; key bits in bold:

Sub getting_values2()

Dim cl As Range, i As Long
Dim MaLstRw As Long, B4Tot As Long

Set WS = ThisWorkbook.Sheets("MAIN")

' clear data any data rows in sub-sheets
Call ClearData

MaLstRw = WS.Range("A" & Rows.Count).End(xlUp).Row
' loop down main sheet
For Each cl In WS.Range("A12:A" & MaLstRw)
    ' check non-zero entries
    If cl.Value <> "" Then
        'find matching sheet
        For i = 1 To Sheets.Count
            With Sheets(i)
                If Sheets(i).Name = cl.Value Then
                ' when found, find last row of that sheet
                    B4Tot = .Range("C" & .Rows.Count).End(xlUp).Row
                    ' insert new row, copying format from above
                    .Rows(B4Tot).EntireRow.Insert Shift:=xlDown, _
                    'copy values from MAIN
                    .Range(.Cells(B4Tot, 1), .Cells(B4Tot, 5)).Value = cl.Offset(0, 2).Resize(1, 5).Value
                    ' write formula in column E
                    .Cells(B4Tot, 6).Formula = "=F" & B4Tot - 1 & " + E" & B4Tot & " - D" & B4Tot
                    ' write formula in column F
                    .Cells(B4Tot, 7).Formula = "=D" & B4Tot & " + E" & B4Tot
                    ' add totals in row below
                    .Cells(B4Tot + 1, 4).Formula = "=SUM(D15:D" & B4Tot & ")"
                    .Cells(B4Tot + 1, 5).Formula = "=SUM(E15:E" & B4Tot & ")"
                End If
            End With
        Next i
    End If
Next cl

MsgBox "Data replaced in sub-sheets"

End Sub

I note that you have about 280 odd rows in MAIN with no data in column A (but the sub skips over those).

Hope this fixes things for you.



thanks John, every thing is ok except one thing when add new data before TOTAL row it doesn't include for summing in last row .it keep old summing without change in last row .
Alaa (rep: 14) Sep 22, '22 at 12:10 am

Please see my Answer and revised file. It adds the additional lines:
' add totals in row below
 .Cells(B4Tot + 1, 4).Formula = "=SUM(D15:D" & B4Tot & ")"
 .Cells(B4Tot + 1, 5).Formula = "=SUM(E15:E" & B4Tot & ")"
John_Ru (rep: 3992) Sep 22, '22 at 2:25 am
perfect !
much appreciated for  your help .
Alaa (rep: 14) Sep 22, '22 at 3:38 am
Glad it worked. Thanks for selecting my Answer, Alla.

I wouldn't say it's perfect though. It's okay for a few "codes" but you need to have a sheet per code set up already (and could miss some data). Personally, I would:

    1. Create a macro to extract all unique codes and check a sheet exists per code (optionally creating new ones and/or telling the user to add starting values)
    2. Replace the gettingvalues2 macro above with one which:
        a. loops through all of the unique codes
        b. uses autofilter to select matching cells in MAIN
        c. erases all data below row 17 in the matching sheet then writes the visible cells there (in one go)
        d. adds the extra column E & F* 
        e. put a new Totals row below the copied data*

* I would NOT add formula (like =D18+E18) in cells, just the value (unless other users need to check those formulae).
John_Ru (rep: 3992) Sep 22, '22 at 5:26 am
  based  on small data and  not  big  data     despite of  many  loops  for  the  code , at  least better  than  select & copy,paste way .
Alaa (rep: 14) Sep 22, '22 at 7:13 am
Okay Alla. I wasn't sure how varied your real data would be.
John_Ru (rep: 3992) Sep 22, '22 at 8:15 am
Add to Discussion

Answer the Question

You must create an account to use the forum. Create an Account or Login