PDA

View Full Version : 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

23837
23838

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 (tel:9782111111)
9782111112 (tel:9782111112)
9782111113 (tel:9782111113)



EXCLUDE


9782111112 (tel: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 (tel:15225-9782111111) CONTENT CONTENT CONTENT CONTENT
15226-9782111111 (tel:15226-9782111111) CONTENT CONTENT CONTENT CONTENT
15227-9782111111 (tel:15227-9782111111) CONTENT CONTENT CONTENT CONTENT
15228-9782111111 (tel:15228-9782111111) CONTENT CONTENT CONTENT CONTENT


15225-9782111113 (tel:15225-9782111113) CONTENT CONTENT CONTENT CONTENT
15226-9782111113 (tel:15226-9782111113) CONTENT CONTENT CONTENT CONTENT
15227-9782111113 (tel:15227-9782111113) CONTENT CONTENT CONTENT CONTENT
15228-9782111113 (tel: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 CONTENTCONTENTCONTENTCONTENTCONTENTCONTENTCONTENTCONTENTCONTENTCONTENTCONTE NTCONTENTCONTENTCONTENTCONTENTCONTENTCONTENTCONTENTCONTENTCONTENTCONTENTCON TENTCONTENTCONTENTCONTENTCONTENTCONTENTCONTENTCONTENTCONTENTCONTENTCONTENTC ONTENTCONTENTCONTENTCONTENTCONTENT
15226-PHONE CONTENT CONTENT CONTENT CONTENT
15227-PHONE CONTENT CONTENT CONTENT CONTENTCONTENTCONTENTCONTENTCONTENTCONTENTCONTENTCONTENTCONTENTCONTENTCONTE NTCONTENTCONTENTCONTENTCONTENTCONTENTCONTENTCONTENTCONTENTCONTENTCONTENTCON TENTCONTENTCONTENTCONTENTCONTENTCONTENTCONTENTCONTENTCONTENTCONTENTCONTENTC ONTENTCONTENTCONTENTCONTENTCONTENTCONTENTCONTENTCONTENTCONTENTCONTENTCONTEN TCONTENTCONTENTCONTENTCONTENT
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
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..