Excel Macro To Combine Multiple Sheets in one only

**jabe00** · 02-28-2019, 09:05 AM

Hello Everyone,

I would like if someone can help me in what I'm trying to do:

I have a sheet called UNPUT and another one named BASE.

In the sheet INPUT I have a list of the phone numbers
In the sheet BASE I have content from A1:E71

What I want to do is base on INPUT create a copy of BASE and replace the word PHONE with the phone number in the INPUT sheet.

Content Sheet INPUT:

9782111111
9782111112
9782111113

The quantity will change

Content Sheet BASE

15225-PHONE CONTENT  CONTENT CONTENT CONTENT
15226-PHONE CONTENT  CONTENT CONTENT CONTENT
15227-PHONE CONTENT  CONTENT CONTENT CONTENT
15228-PHONE CONTENT  CONTENT CONTENT CONTENT

And the final result should be copy in a new sheet as below with PHONE replaced by the telco as below:

15225-9782111111 CONTENT  CONTENT CONTENT CONTENT
15226-9782111111 CONTENT  CONTENT CONTENT CONTENT
15227-9782111111 CONTENT  CONTENT CONTENT CONTENT
15228-9782111111 CONTENT  CONTENT CONTENT CONTENT

15225-9782111112 CONTENT  CONTENT CONTENT CONTENT
15226-9782111112 CONTENT  CONTENT CONTENT CONTENT
15227-9782111112 CONTENT  CONTENT CONTENT CONTENT
15228-9782111112 CONTENT  CONTENT CONTENT CONTENT

15225-9782111113 CONTENT  CONTENT CONTENT CONTENT
15226-9782111113 CONTENT  CONTENT CONTENT CONTENT
15227-9782111113 CONTENT  CONTENT CONTENT CONTENT
15228-9782111113 CONTENT  CONTENT CONTENT CONTENT

Thanks so much in advance.
Jose

**大灰狼1976** · 03-05-2019, 01:01 AM

Hi jabe00!
Please refer to the Attachment.

**jabe00** · 03-05-2019, 03:06 PM

Thanks for the file, can you just paste the code here as I'm unable to Download/Open and also I have to change some used words like Phone for the real one used in my files.

Thanks,

**大灰狼1976** · 03-05-2019, 06:21 PM

OK!

Private Sub CommandButton1_Click()
Dim arr, arr1, arrRst, i&, j&, k&, r&, sh As Worksheet
arr = Sheets("INPUT").[a1].CurrentRegion
arr1 = Sheets("BASE").[a1].CurrentRegion
ReDim arrRst(1 To (UBound(arr) - 1) * UBound(arr1), 1 To UBound(arr1, 2))
For i = 2 To UBound(arr)
  For k = 2 To UBound(arr1)
    r = r + 1
    arrRst(r, 1) = Replace(arr1(k, 1), "PHONE", arr(i, 1))
    For j = 2 To UBound(arr1, 2)
      arrRst(r, j) = arr1(k, j)
    Next j
  Next k
  r = r + 1
Next i
On Error Resume Next
Set sh = Sheets("RESULT")
If sh Is Nothing Then
  Worksheets.Add(After:=Sheets(Sheets.Count)).Name = "RESULT"
Else
  sh.Cells.Clear
End If
On Error GoTo 0
With Sheets("RESULT")
  .[a1].Resize(UBound(arrRst, 2), UBound(arr1, 2)) = Application.Index(arr1, 1)
  .[a2].Resize(UBound(arrRst), UBound(arrRst, 2)) = arrRst
  .Activate
End With
End Sub

INPUT.jpg
BASE.png

**jabe00** · 03-05-2019, 08:21 PM

Thanks so much for your help, that works perfect for I wanted to do... I really appreciate!!!

Thanks,

**jabe00** · 03-06-2019, 08:27 AM

Thanks again 大灰狼1976 , after a successful run for you code for 100 phones, I found that it will override the old ones, so I need to skip those one, and the idea I have is create another worksheet with those Phones so the code can compare with the ones in the input and if is there do nothing.

Do you think that is possible to do what I'm asking?

INPUT

9782111111
9782111112
9782111113

EXCLUDE

9782111112

BASE

15225-PHONE CONTENT  CONTENT CONTENT CONTENT
15226-PHONE CONTENT  CONTENT CONTENT CONTENT
15227-PHONE CONTENT  CONTENT CONTENT CONTENT
15228-PHONE CONTENT  CONTENT CONTENT CONTENT

RESULT

15225-9782111111 CONTENT  CONTENT CONTENT CONTENT
15226-9782111111 CONTENT  CONTENT CONTENT CONTENT
15227-9782111111 CONTENT  CONTENT CONTENT CONTENT
15228-9782111111 CONTENT  CONTENT CONTENT CONTENT


15225-9782111113 CONTENT  CONTENT CONTENT CONTENT
15226-9782111113 CONTENT  CONTENT CONTENT CONTENT
15227-9782111113 CONTENT  CONTENT CONTENT CONTENT
15228-9782111113 CONTENT  CONTENT CONTENT CONTENT

Thanks again,

**大灰狼1976** · 03-06-2019, 06:16 PM

OK!

Private Sub CommandButton1_Click()
Dim arr, arr1, arrRst, i&, j&, k&, r&, sh As Worksheet, rng As Range
arr = Sheets("INPUT").[a1].CurrentRegion
arr1 = Sheets("BASE").[a1].CurrentRegion
ReDim arrRst(1 To (UBound(arr) - 1) * UBound(arr1), 1 To UBound(arr1, 2))
For i = 2 To UBound(arr)
  Set rng = Sheets("EXCLUDE").Columns(1).Find(arr(i, 1), LOOKAT:=xlWhole)
  If rng Is Nothing Then
    For k = 2 To UBound(arr1)
      r = r + 1
      arrRst(r, 1) = Replace(arr1(k, 1), "PHONE", arr(i, 1))
      For j = 2 To UBound(arr1, 2)
        arrRst(r, j) = arr1(k, j)
      Next j
    Next k
    r = r + 1
  End If
Next i
On Error Resume Next
Set sh = Sheets("RESULT")
If sh Is Nothing Then
  Worksheets.Add(After:=Sheets(Sheets.Count)).Name = "RESULT"
Else
  sh.Cells.Clear
End If
On Error GoTo 0
With Sheets("RESULT")
  .[a1].Resize(UBound(arrRst, 2), UBound(arr1, 2)) = Application.Index(arr1, 1)
  .[a2].Resize(UBound(arrRst), UBound(arrRst, 2)) = arrRst
  .Activate
End With
End Sub

**jabe00** · 03-06-2019, 09:38 PM

Thanks again fr your help!!

I'm getting error in this line as looks like the content in the BASE is more that can handle.

.[a1].Resize(UBound(arrRst, 2), UBound(arr1, 2)) = Application.Index(arr1, 1)

15225-PHONE CONTENT  CONTENT CONTENT CONTENTCONTENTCONTENTCONTENTCONTENTCONTENTCONTENTCONTENTCONTENTCONTENTCONTENTCONTENTCONTENTCONTENTCONTENTCONTENTCONTENTCONTENTCONTENTCONTENTCONTENTCONTENTCONTENTCONTENTCONTENTCONTENTCONTENTCONTENTCONTENTCONTENTCONTENTCONTENTCONTENTCONTENTCONTENTCONTENTCONTENT
15226-PHONE CONTENT  CONTENT CONTENT CONTENT
15227-PHONE CONTENT  CONTENT CONTENT CONTENTCONTENTCONTENTCONTENTCONTENTCONTENTCONTENTCONTENTCONTENTCONTENTCONTENTCONTENTCONTENTCONTENTCONTENTCONTENTCONTENTCONTENTCONTENTCONTENTCONTENTCONTENTCONTENTCONTENTCONTENTCONTENTCONTENTCONTENTCONTENTCONTENTCONTENTCONTENTCONTENTCONTENTCONTENTCONTENTCONTENTCONTENTCONTENTCONTENTCONTENTCONTENTCONTENTCONTENTCONTENTCONTENTCONTENT
15228-PHONE CONTENT  CONTENT CONTENT CONTENT

Please Note: If I reduce the content, works fine, but in some cases need to be larger.

Thanks again in advance.

**大灰狼1976** · 03-06-2019, 10:17 PM

I'm sorry for i had a mistake, but i think that is not the Error reason.
.[a1].Resize(UBound(arrRst, 2), UBound(arr1, 2)) = Application.Index(arr1, 1)
change into:
.[a1].Resize(, UBound(arr1, 2)) = Application.Index(arr1, 1)

It's defficult to find error reason without data sample, I need to debug to find out why.

**大灰狼1976** · 03-06-2019, 10:52 PM

I think i found the reason, When the string length exceeds 255, Application.index () will make mistakes.

Private Sub CommandButton1_Click()
Dim arr, arr1, arr2, arrRst, i&, j&, k&, r&, sh As Worksheet, rng As Range
arr = Sheets("INPUT").[a1].CurrentRegion
arr1 = Sheets("BASE").[a1].CurrentRegion
ReDim arrRst(1 To (UBound(arr) - 1) * UBound(arr1), 1 To UBound(arr1, 2))
For i = 2 To UBound(arr)
  Set rng = Sheets("EXCLUDE").Columns(1).Find(arr(i, 1), LOOKAT:=xlWhole)
  If rng Is Nothing Then
    For k = 2 To UBound(arr1)
      r = r + 1
      arrRst(r, 1) = Replace(arr1(k, 1), "PHONE", arr(i, 1))
      For j = 2 To UBound(arr1, 2)
        arrRst(r, j) = arr1(k, j)
      Next j
    Next k
    r = r + 1
  End If
Next i
On Error Resume Next
Set sh = Sheets("RESULT")
If sh Is Nothing Then
  Worksheets.Add(After:=Sheets(Sheets.Count)).Name = "RESULT"
Else
  sh.Cells.Clear
End If
On Error GoTo 0
ReDim arr2(1 To UBound(arr1, 2))
For j = 1 To UBound(arr2)
  arr2(j) = arr1(1, j)
Next j
With Sheets("RESULT")
  .[a1].Resize(, UBound(arr2)) = arr2
  .[a2].Resize(UBound(arrRst), UBound(arrRst, 2)) = arrRst
  .Activate
End With
End Sub

**jabe00** · 03-07-2019, 08:14 AM

This one worked very good with not error... Thanks so much!!!

**jabe00** · 03-28-2019, 07:36 AM

Hi,

I have a question, do you think will be possible to add that the content in the sheet RESULT can be saved in a new file in the same directory in .csv?

Thanks in advance

**大灰狼1976** · 03-28-2019, 06:20 PM

Hi jabe!

Private Sub CommandButton1_Click()
Dim arr, arr1, arr2, arrRst, i&, j&, k&, r&, sh As Worksheet, rng As Range
arr = Sheets("INPUT").[a1].CurrentRegion
arr1 = Sheets("BASE").[a1].CurrentRegion
ReDim arrRst(1 To (UBound(arr) - 1) * UBound(arr1), 1 To UBound(arr1, 2))
For i = 2 To UBound(arr)
  Set rng = Sheets("EXCLUDE").Columns(1).Find(arr(i, 1), LOOKAT:=xlWhole)
  If rng Is Nothing Then
    For k = 2 To UBound(arr1)
      r = r + 1
      arrRst(r, 1) = Replace(arr1(k, 1), "PHONE", arr(i, 1))
      For j = 2 To UBound(arr1, 2)
        arrRst(r, j) = arr1(k, j)
      Next j
    Next k
    r = r + 1
  End If
Next i
On Error Resume Next
Set sh = Sheets("RESULT")
If sh Is Nothing Then
  Worksheets.Add(After:=Sheets(Sheets.Count)).Name = "RESULT"
Else
  sh.Cells.Clear
End If
On Error GoTo 0
ReDim arr2(1 To UBound(arr1, 2))
For j = 1 To UBound(arr2)
  arr2(j) = arr1(1, j)
Next j
With Sheets("RESULT")
  .[a1].Resize(, UBound(arr2)) = arr2
  .[a2].Resize(UBound(arrRst), UBound(arrRst, 2)) = arrRst
  .Activate
  .Copy
  ActiveSheet.SaveAs ThisWorkbook.Path & "/" & .Name & Format(Now(), "hhmmss"), xlCSV
  ActiveWorkbook.Close False
End With
End Sub

**jabe00** · 03-29-2019, 07:28 AM

Originally Posted by 大灰狼1976

Hi jabe!

Private Sub CommandButton1_Click()
Dim arr, arr1, arr2, arrRst, i&, j&, k&, r&, sh As Worksheet, rng As Range
arr = Sheets("INPUT").[a1].CurrentRegion
arr1 = Sheets("BASE").[a1].CurrentRegion
ReDim arrRst(1 To (UBound(arr) - 1) * UBound(arr1), 1 To UBound(arr1, 2))
For i = 2 To UBound(arr)
  Set rng = Sheets("EXCLUDE").Columns(1).Find(arr(i, 1), LOOKAT:=xlWhole)
  If rng Is Nothing Then
    For k = 2 To UBound(arr1)
      r = r + 1
      arrRst(r, 1) = Replace(arr1(k, 1), "PHONE", arr(i, 1))
      For j = 2 To UBound(arr1, 2)
        arrRst(r, j) = arr1(k, j)
      Next j
    Next k
    r = r + 1
  End If
Next i
On Error Resume Next
Set sh = Sheets("RESULT")
If sh Is Nothing Then
  Worksheets.Add(After:=Sheets(Sheets.Count)).Name = "RESULT"
Else
  sh.Cells.Clear
End If
On Error GoTo 0
ReDim arr2(1 To UBound(arr1, 2))
For j = 1 To UBound(arr2)
  arr2(j) = arr1(1, j)
Next j
With Sheets("RESULT")
  .[a1].Resize(, UBound(arr2)) = arr2
  .[a2].Resize(UBound(arrRst), UBound(arrRst, 2)) = arrRst
  .Activate
  .Copy
  ActiveSheet.SaveAs ThisWorkbook.Path & "/" & .Name & Format(Now(), "hhmmss"), xlCSV
  ActiveWorkbook.Close False
End With
End Sub

Fantastic!!! Thanks so much..

Thread: Excel Macro To Combine Multiple Sheets in one only

Thread Tools

Display

Excel Macro To Combine Multiple Sheets in one only

Posting Permissions