Need code..

VBABEGINER

Well-known Member
Joined
Jun 15, 2011
Messages
1,284
Office Version
  1. 365
Platform
  1. Windows
Hi All,

I need assistance in entire code please..
It's easy to make the code b'coz, formats of the sheet are same..

I have 7-8 sheets. I want all data combine in single sheet..

Format of sheet like below--

Columns A, B, C, D & E are merged from row 2 to 24. i.e 23 row's.

Column F contains, region names which are fix 23.

From Col G, my monthly data starts. Like,

Col G - Jan'18
Col H - Feb'18
Col I - Mar'18
Col J - Apr'18
Col K - YTD'18

Col L - Comments

Now, Sheet1 person only have one metric data hence data is onlt till row 2 to 24. (Fix)

Sheet2 person also have data row 2 to 24, as only have one metric data.

Sheet3 person have 5 metric data hence rows grouping like this..
2 to 24
25 to 47
48 to ....and more..

So, all this data gets combine in one sheet..

Can anyone help on this..
 

Excel Facts

Fastest way to copy a worksheet?
Hold down the Ctrl key while dragging tab for Sheet1 to the right. Excel will make a copy of the worksheet.
Till now I have designed..
Code:
Dim i As Long, x As Long, j As Long
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Sheets.Add(After:=Sheets(Sheets.Count)).Name = "Combine"
Dim ws As Worksheet
For Each ws In ThisWorkbook.Sheets
    If ws.Name = "Combine" Then
    Else
        ws.Activate
        i = Range("F" & Rows.Count).End(xlUp).Row
        LC = Cells(1, Columns.Count).End(xlToLeft).Column
'        Range("A2:L" & i).Select
'        Worksheets("Combine").Select
        
        
        ws.Range(ws.Cells(2, 1), ws.Cells(i, LC)).Copy
        With Worksheets("Combine")
            .Range("A" & .Range("A" & .Rows.Count).End(xlUp).Row).Offset(1, 0).Paste xlpaste
        End With
 
Upvote 0
Hello All,

with this regards, I have designed the code..
Code:
Sub fnCombine()
Dim i As Long, x As Long, j As Long
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Sheets.Add(After:=Sheets(Sheets.Count)).Name = "Combine"
Dim ws As Worksheet
For Each ws In ThisWorkbook.Sheets
    If ws.Name = "Combine" Then
    Else
        ws.Activate
        i = Range("F" & Rows.Count).End(xlUp).Row
        LC = Cells(1, Columns.Count).End(xlToLeft).Column
        If ws.Index = 1 Then
            Range("A1:L" & i).Select
            Selection.Copy
            Worksheets("Combine").Select
            Range("A1").Select
            ActiveSheet.Paste
        Else
        Range("A2:L" & i).Select
        Selection.Copy
        Worksheets("Combine").Select
        j = Range("F" & Rows.Count).End(xlUp).Row
        Range("A" & j + 1).Select
        ActiveSheet.Paste
        Application.CutCopyMode = False
        End If
    End If
Next
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub


But Now I have some other view requires.. Therefore, above code will not helpful more.


I trying to re-design the code like,
Code:
Sub fnCombine()
Dim i As Long, j As Long
Dim ws As Worksheet


Application.ScreenUpdating = False
Application.DisplayAlerts = False


Sheets.Add(After:=Sheets(Sheets.Count)).Name = "Combine"
For Each ws In ThisWorkbook.Sheets
    If ws.Name = "Combine" Then
    Else
        ws.Activate
        i = Range("F" & Rows.Count).End(xlUp).Row
        If ws.Index = 1 Then
            Range("A1:G" & i).Select
            Selection.Copy
            Worksheets("Combine").Select
            Range("A1").Select
            ActiveSheet.Paste
        Else
        Range("A2:G" & i).Select
        Selection.Copy
        Worksheets("Combine").Select
        j = Range("F" & Rows.Count).End(xlUp).Row
        Range("A" & j + 1).Select
        ActiveSheet.Paste
        Application.CutCopyMode = False
        End If
    End If
Next


[COLOR=#ff0000]    Dim x As Integer[/COLOR]
[COLOR=#ff0000]
[/COLOR]
[COLOR=#ff0000]    x = Sheets.Count[/COLOR]
[COLOR=#ff0000]    For i = x To 1 Step -1[/COLOR]
[COLOR=#ff0000]    [/COLOR]
[COLOR=#ff0000]    [/COLOR]
[COLOR=#ff0000]    Next i[/COLOR]




Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

In the red part area, I think i need do until or do...loop through sheets...The reason..

Now my criteria is, in the first part of code..I'm copying data till col G in "combine" sheet. below to each other.

Col G = Jan'18 data (every sheet).

Col H = Feb'18 data
Col I = Mar'18 data
Col J = Apr'18 data
Col K = YTD'2018
Col L = Comments


Now, I need again go to 1st sheet, copy data from A2 till F last rows AND Col H data --> Combine Sheet --> paste in last row + 1...

I dont know how do i loop this till Col L of every sheet..

Note : Last sheet which is "Combine" should ignore in copy task..
 
Upvote 0
Unable to loop or logic..
Code:
Sub fnCombine()
Dim i As Long, j As Long, LC As Integer
Dim ws As Worksheet
Dim x As Integer, z As Integer


Application.ScreenUpdating = False
Application.DisplayAlerts = False


Sheets.Add(After:=Sheets(Sheets.Count)).Name = "Combine"
For Each ws In ThisWorkbook.Sheets
    If ws.Name = "Combine" Then
    Else
        ws.Activate
        i = Range("F" & Rows.Count).End(xlUp).Row
        LC = Cells(1, Columns.Count).End(xlToLeft).Column
        If ws.Index = 1 Then
            Range("A1:G" & i).Select
            Selection.Copy
            Worksheets("Combine").Select
            Range("A1").Select
            ActiveSheet.Paste
        Else
        Range("A2:G" & i).Select
        Selection.Copy
        Worksheets("Combine").Select
        j = Range("F" & Rows.Count).End(xlUp).Row
        Range("A" & j + 1).Select
        ActiveSheet.Paste
        Application.CutCopyMode = False
        End If
    End If
Next


[COLOR=#ff0000]    x = Sheets.Count[/COLOR]
[COLOR=#ff0000]    [/COLOR]
[COLOR=#ff0000]    For z = Range("H") To LC[/COLOR]
[COLOR=#ff0000]    [/COLOR]
[COLOR=#ff0000]    If x.Index = 1 Then[/COLOR]
[COLOR=#ff0000]        Range("H2:H" & i).Select[/COLOR]
[COLOR=#ff0000]        Selection.Copy[/COLOR]
[COLOR=#ff0000]    [/COLOR]
    
    End If
    
    Next z




Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
 
Upvote 0
As per instruction....which I got yesterday...if no one is able to respond then I can close this thread....

And will post new one, so I can get some help from another query...
 
Upvote 0

Forum statistics

Threads
1,223,236
Messages
6,170,917
Members
452,366
Latest member
TePunaBloke

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top